Changeset 15830


Ignore:
Timestamp:
Jun 4, 2013, 10:35:12 AM (6 years ago)
Author:
rme
Message:

ASDF 3.0.1.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r15753 r15830  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.32: Another System Definition Facility.
     2;;; This is ASDF 3.0.1: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    7272           (away (format nil "~A-~A" :asdf existing-version)))
    7373      (when (and existing-version (< existing-version-number
    74                                      (or #+abcl 2.25 #+cmu 2.018 2.27)))
     74                                     (or #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27)))
    7575        (rename-package :asdf away)
    7676        (when *load-verbose*
    77           (format t "; Renamed old ~A package away to ~A~%" :asdf away))))))
     77          (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
    7878
    7979;;;; ---------------------------------------------------------------------------
     
    10151015  (:export
    10161016   ;; magic helper to define debugging functions:
    1017    #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
     1017   #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
    10181018   #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
    10191019   #:if-let ;; basic flow control
    1020    #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
     1020   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
     1021   #:remove-plist-keys #:remove-plist-key ;; plists
    10211022   #:emptyp ;; sequences
    1022    #:strcat #:first-char #:last-char #:split-string ;; strings
     1023   #:+non-base-chars-exist-p+ ;; characters
     1024   #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
     1025   #:first-char #:last-char #:split-string
    10231026   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
    10241027   #:find-class* ;; CLOS
     
    10931096;;; Magic debugging help. See contrib/debug.lisp
    10941097(with-upgradability ()
    1095   (defvar *asdf-debug-utility*
     1098  (defvar *uiop-debug-utility*
    10961099    '(or (ignore-errors
    1097           (symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp"))
    1098       (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
     1100          (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))
     1101      (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp"))
    10991102    "form that evaluates to the pathname to your favorite debugging utilities")
    11001103
    1101   (defmacro asdf-debug (&rest keys)
     1104  (defmacro uiop-debug (&rest keys)
    11021105    `(eval-when (:compile-toplevel :load-toplevel :execute)
    1103        (load-asdf-debug-utility ,@keys)))
    1104 
    1105   (defun load-asdf-debug-utility (&key package utility-file)
     1106       (load-uiop-debug-utility ,@keys)))
     1107
     1108  (defun load-uiop-debug-utility (&key package utility-file)
    11061109    (let* ((*package* (if package (find-package package) *package*))
    11071110           (keyword (read-from-string
    11081111                     (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
    11091112      (unless (member keyword *features*)
    1110         (let* ((utility-file (or utility-file *asdf-debug-utility*))
     1113        (let* ((utility-file (or utility-file *uiop-debug-utility*))
    11111114               (file (ignore-errors (probe-file (eval utility-file)))))
    11121115          (if file (load file)
     
    11571160        (cond
    11581161          ((zerop i) (return (null l)))
    1159           ((not (consp l)) (return nil))))))
     1162          ((not (consp l)) (return nil)))))
     1163
     1164  (defun ensure-list (x)
     1165    (if (listp x) x (list x))))
     1166
    11601167
    11611168;;; remove a key from a plist, i.e. for keyword argument cleanup
     
    11811188
    11821189
     1190;;; Characters
     1191(with-upgradability ()
     1192  (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
     1193  (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
     1194
     1195
    11831196;;; Strings
    11841197(with-upgradability ()
     1198  (defun base-string-p (string)
     1199    (declare (ignorable string))
     1200    (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
     1201
     1202  (defun strings-common-element-type (strings)
     1203    (declare (ignorable strings))
     1204    #-non-base-chars-exist-p 'character
     1205    #+non-base-chars-exist-p
     1206    (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s)))
     1207        'base-char 'character))
     1208
     1209  (defun reduce/strcat (strings &key key start end)
     1210    "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
     1211NIL is interpreted as an empty string. A character is interpreted as a string of length one."
     1212    (when (or start end) (setf strings (subseq strings start end)))
     1213    (when key (setf strings (mapcar key strings)))
     1214    (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
     1215                                      :element-type (strings-common-element-type strings))
     1216          :with pos = 0
     1217          :for input :in strings
     1218          :do (etypecase input
     1219                (null)
     1220                (character (setf (char output pos) input) (incf pos))
     1221                (string (replace output input :start1 pos) (incf pos (length input))))
     1222          :finally (return output)))
     1223
    11851224  (defun strcat (&rest strings)
    1186     (apply 'concatenate 'string strings))
     1225    (reduce/strcat strings))
    11871226
    11881227  (defun first-char (s)
     
    12051244            :for start = (if (and max (>= words (1- max)))
    12061245                             (done)
    1207                              (position-if #'separatorp string :end end :from-end t)) :do
    1208                                (when (null start)
    1209                                  (done))
    1210                                (push (subseq string (1+ start) end) list)
    1211                                (incf words)
    1212                                (setf end start))))))
     1246                             (position-if #'separatorp string :end end :from-end t))
     1247            :do (when (null start) (done))
     1248                (push (subseq string (1+ start) end) list)
     1249                (incf words)
     1250                (setf end start))))))
    12131251
    12141252  (defun string-prefix-p (prefix string)
     
    14201458    (etypecase x
    14211459      (symbol (typep condition x))
    1422       ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
     1460      ((simple-vector 2)
     1461       (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
    14231462      (function (funcall x condition))
    14241463      (string (and (typep condition 'simple-condition)
     
    24282467       (translate-pathname path absolute-source destination))))
    24292468
    2430   (defvar *output-translation-function* 'identity)) ; Hook for output translations
    2431 
     2469  (defvar *output-translation-function* 'identity
     2470    "Hook for output translations.
     2471
     2472This function needs to be idempotent, so that actions can work
     2473whether their inputs were translated or not,
     2474which they will be if we are composing operations. e.g. if some
     2475create-lisp-op creates a lisp file from some higher-level input,
     2476you need to still be able to use compile-op on that lisp file."))
    24322477
    24332478;;;; -------------------------------------------------------------------------
     
    24422487   #:native-namestring #:parse-native-namestring
    24432488   ;; Probing the filesystem
    2444    #:truename* #:safe-file-write-date #:probe-file*
     2489   #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
    24452490   #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
    24462491   #:collect-sub*directories
     
    24572502   #:ensure-all-directories-exist
    24582503   #:rename-file-overwriting-target
    2459    #:delete-file-if-exists))
     2504   #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
    24602505(in-package :uiop/filesystem)
    24612506
     
    25652610                (file-error () nil)))))))
    25662611
     2612  (defun directory-exists-p (x)
     2613    (let ((p (probe-file* x :truename t)))
     2614      (and (directory-pathname-p p) p)))
     2615
     2616  (defun file-exists-p (x)
     2617    (let ((p (probe-file* x :truename t)))
     2618      (and (file-pathname-p p) p)))
     2619
    25672620  (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
    25682621    (apply 'directory pathname-spec
    25692622           (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
    2570                                #+clozure '(:follow-links nil)
     2623                               #+(or clozure digitool) '(:follow-links nil)
    25712624                               #+clisp '(:circle t :if-does-not-exist :ignore)
    25722625                               #+(or cmu scl) '(:follow-links nil :truenamep nil)
     
    26032656          (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
    26042657        (setf pattern (make-pathname-logical pattern (pathname-host dir))))
    2605       (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
     2658      (let* ((pat (merge-pathnames* pattern dir))
     2659             (entries (append (ignore-errors (directory* pat))
     2660                              #+clisp
     2661                              (when (equal :wild (pathname-type pattern))
     2662                                (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
    26062663        (filter-logical-directory-results
    26072664         directory entries
     
    26502707
    26512708  (defun collect-sub*directories (directory collectp recursep collector)
    2652     (when (funcall collectp directory)
    2653       (funcall collector directory))
     2709    (when (call-function collectp directory)
     2710      (call-function collector directory))
    26542711    (dolist (subdir (subdirectories directory))
    2655       (when (funcall recursep subdir)
     2712      (when (call-function recursep subdir)
    26562713        (collect-sub*directories subdir collectp recursep collector)))))
    26572714
     
    27912848          (check want-relative (relative-pathname-p p) "Expected a relative pathname")
    27922849          (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
    2793           (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
     2850          (transform ensure-absolute (not (absolute-pathname-p p))
     2851                     (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
    27942852          (check ensure-absolute (absolute-pathname-p p)
    27952853                 "Could not make into an absolute pathname even after merging with ~S" defaults)
     
    28512909          :collect (apply 'parse-native-namestring namestring constraints)))
    28522910
    2853   (defun getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
     2911  (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
     2912    ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
    28542913    (apply 'parse-native-namestring (getenvp x)
     2914           :ensure-directory (or ensure-directory want-directory)
    28552915           :on-error (or on-error
    28562916                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
     
    29082968
    29092969  (defun delete-file-if-exists (x)
    2910     (when x (handler-case (delete-file x) (file-error () nil)))))
    2911 
     2970    (when x (handler-case (delete-file x) (file-error () nil))))
     2971
     2972  (defun delete-empty-directory (directory-pathname)
     2973    "Delete an empty directory"
     2974    #+(or abcl digitool gcl) (delete-file directory-pathname)
     2975    #+allegro (excl:delete-directory directory-pathname)
     2976    #+clisp (ext:delete-directory directory-pathname)
     2977    #+clozure (ccl::delete-empty-directory directory-pathname)
     2978    #+(or cmu scl) (multiple-value-bind (ok errno)
     2979                       (unix:unix-rmdir (native-namestring directory-pathname))
     2980                     (unless ok
     2981                       #+cmu (error "Error number ~A when trying to delete directory ~A"
     2982                                    errno directory-pathname)
     2983                       #+scl (error "~@<Error deleting ~S: ~A~@:>"
     2984                                    directory-pathname (unix:get-unix-error-msg errno))))
     2985    #+cormanlisp (win32:delete-directory directory-pathname)
     2986    #+ecl (si:rmdir directory-pathname)
     2987    #+lispworks (lw:delete-directory directory-pathname)
     2988    #+mkcl (mkcl:rmdir directory-pathname)
     2989    #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
     2990               `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
     2991               `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
     2992    #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl)
     2993    (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl
     2994
     2995  (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
     2996    "Delete a directory including all its recursive contents, aka rm -rf.
     2997
     2998To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
     2999a physical non-wildcard directory pathname (not namestring).
     3000
     3001If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
     3002if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
     3003
     3004Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
     3005the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
     3006which in practice is thus compulsory, and validates by returning a non-NIL result.
     3007If you're suicidal or extremely confident, just use :VALIDATE T."
     3008    (check-type if-does-not-exist (member :error :ignore))
     3009    (cond
     3010      ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
     3011                 (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
     3012       (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
     3013              'delete-filesystem-tree directory-pathname))
     3014      ((not validatep)
     3015       (error "~S was asked to delete ~S but was not provided a validation predicate"
     3016              'delete-filesystem-tree directory-pathname))
     3017      ((not (call-function validate directory-pathname))
     3018       (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
     3019              'delete-filesystem-tree directory-pathname validate))
     3020      ((not (directory-exists-p directory-pathname))
     3021       (ecase if-does-not-exist
     3022         (:error
     3023          (error "~S was asked to delete ~S but the directory does not exist"
     3024              'delete-filesystem-tree directory-pathname))
     3025         (:ignore nil)))
     3026      #-(or allegro cmu clozure sbcl scl)
     3027      ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
     3028       ;; except on implementations where we can prevent DIRECTORY from following symlinks;
     3029       ;; instead spawn a standard external program to do the dirty work.
     3030       (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
     3031      (t
     3032       ;; On supported implementation, call supported system functions
     3033       #+allegro (symbol-call :excl.osi :delete-directory-and-files
     3034                              directory-pathname :if-does-not-exist if-does-not-exist)
     3035       #+clozure (ccl:delete-directory directory-pathname)
     3036       #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
     3037       #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
     3038                  `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
     3039                  '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
     3040       ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
     3041       ;; do things the hard way.
     3042       #-(or allegro clozure genera sbcl)
     3043       (let ((sub*directories
     3044               (while-collecting (c)
     3045                 (collect-sub*directories directory-pathname t t #'c))))
     3046             (dolist (d (nreverse sub*directories))
     3047               (map () 'delete-file (directory-files d))
     3048               (delete-empty-directory d)))))))
    29123049
    29133050;;;; ---------------------------------------------------------------------------
     
    29253062   #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
    29263063   #:with-output #:output-string #:with-input
    2927    #:with-input-file #:call-with-input-file
     3064   #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
    29283065   #:finish-outputs #:format! #:safe-format!
    2929    #:copy-stream-to-stream #:concatenate-files
     3066   #:copy-stream-to-stream #:concatenate-files #:copy-file
    29303067   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
    29313068   #:slurp-stream-forms #:slurp-stream-form
     
    30993236      (funcall thunk s)))
    31003237
    3101   (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
    3102     (declare (ignore element-type external-format))
    3103     `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
    3104 
     3238  (defmacro with-input-file ((var pathname &rest keys
     3239                              &key element-type external-format if-does-not-exist)
     3240                             &body body)
     3241    (declare (ignore element-type external-format if-does-not-exist))
     3242    `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
     3243
     3244  (defun call-with-output-file (pathname thunk
     3245                                &key
     3246                                  (element-type *default-stream-element-type*)
     3247                                  (external-format *utf-8-external-format*)
     3248                                  (if-exists :error)
     3249                                  (if-does-not-exist :create))
     3250    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
     3251Other keys are accepted but discarded."
     3252    #+gcl2.6 (declare (ignore external-format))
     3253    (with-open-file (s pathname :direction :output
     3254                                :element-type element-type
     3255                                #-gcl2.6 :external-format #-gcl2.6 external-format
     3256                                :if-exists if-exists
     3257                                :if-does-not-exist if-does-not-exist)
     3258      (funcall thunk s)))
     3259
     3260  (defmacro with-output-file ((var pathname &rest keys
     3261                               &key element-type external-format if-exists if-does-not-exist)
     3262                              &body body)
     3263    (declare (ignore element-type external-format if-exists if-does-not-exist))
     3264    `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
    31053265
    31063266;;; Ensure output buffers are flushed
     
    31593319          (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
    31603320
     3321  (defun copy-file (input output)
     3322    ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
     3323    (concatenate-files (list input) output))
     3324
    31613325  (defun slurp-stream-string (input &key (element-type 'character))
    31623326    "Read the contents of the INPUT stream as a string"
     
    33093473    (check-type direction (member :output :io))
    33103474    (loop
    3311       :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
     3475      :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
    33123476      :for counter :from (random (ash 1 32))
    33133477      :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
     
    34103574  (defvar *image-restore-hook* nil
    34113575    "Functions to call (in reverse order) when the image is restored")
     3576
     3577  (defvar *image-restored-p* nil
     3578    "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
    34123579
    34133580  (defvar *image-prelude* nil
     
    36033770                          ((:restore-hook *image-restore-hook*) *image-restore-hook*)
    36043771                          ((:prelude *image-prelude*) *image-prelude*)
    3605                           ((:entry-point *image-entry-point*) *image-entry-point*))
     3772                          ((:entry-point *image-entry-point*) *image-entry-point*)
     3773                          (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
     3774    (when *image-restored-p*
     3775      (if if-already-restored
     3776          (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
     3777          (return-from restore-image)))
    36063778    (with-fatal-condition-handler ()
     3779      (setf *image-restored-p* :in-progress)
    36073780      (call-image-restore-hook)
    36083781      (standard-eval-thunk *image-prelude*)
     3782      (setf *image-restored-p* t)
    36093783      (let ((results (multiple-value-list
    36103784                      (if *image-entry-point*
     
    36193793
    36203794(with-upgradability ()
    3621   #-(or ecl mkcl)
    36223795  (defun dump-image (filename &key output-name executable
    36233796                                ((:postlude *image-postlude*) *image-postlude*)
    3624                                 ((:dump-hook *image-dump-hook*) *image-dump-hook*))
     3797                                ((:dump-hook *image-dump-hook*) *image-dump-hook*)
     3798                                #+clozure prepend-symbols #+clozure (purify t))
    36253799    (declare (ignorable filename output-name executable))
    36263800    (setf *image-dumped-p* (if executable :executable t))
     3801    (setf *image-restored-p* :in-regress)
    36273802    (standard-eval-thunk *image-postlude*)
    36283803    (call-image-dump-hook)
     3804    (setf *image-restored-p* nil)
    36293805    #-(or clisp clozure cmu lispworks sbcl scl)
    36303806    (when executable
     
    36453821              :norc t :script nil :init-function #'restore-image)))
    36463822    #+clozure
    3647     (ccl:save-application filename :prepend-kernel t
    3648                                    :toplevel-function (when executable #'restore-image))
     3823    (flet ((dump (prepend-kernel)
     3824             (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
     3825                                            :toplevel-function (when executable #'restore-image))))
     3826      ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
     3827      (if prepend-symbols
     3828          (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
     3829            (require 'elf)
     3830            (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
     3831            (dump path))
     3832          (dump t)))
    36493833    #+(or cmu scl)
    36503834    (progn
     
    36703854             (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
    36713855    #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
    3672     (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
    3673          filename (nth-value 1 (implementation-type))))
    3674 
    3675 
    3676   #+ecl
     3856    (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
     3857           'dump-image filename (nth-value 1 (implementation-type))))
     3858
    36773859  (defun create-image (destination object-files
    3678                        &key kind output-name prologue-code epilogue-code
    3679                          (prelude () preludep) (entry-point () entry-point-p) build-args)
     3860                       &key kind output-name prologue-code epilogue-code
     3861                         (prelude () preludep) (postlude () postludep)
     3862                         (entry-point () entry-point-p) build-args)
     3863    (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
     3864                        prelude preludep postlude postludep entry-point entry-point-p build-args))
    36803865    ;; Is it meaningful to run these in the current environment?
    36813866    ;; only if we also track the object files that constitute the "current" image,
    36823867    ;; and otherwise simulate dump-image, including quitting at the end.
    3683     ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
    3684     (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
    3685     (apply 'c::builder
    3686            kind (pathname destination)
    3687            :lisp-files object-files
    3688            :init-name (c::compute-init-name (or output-name destination) :kind kind)
    3689            :prologue-code prologue-code
    3690            :epilogue-code
    3691            `(progn
    3692               ,epilogue-code
    3693               ,@(when (eq kind :program)
    3694                   `((setf *image-dumped-p* :executable)
    3695                     (restore-image ;; default behavior would be (si::top-level)
    3696                      ,@(when preludep `(:prelude ',prelude))
    3697                      ,@(when entry-point-p `(:entry-point ',entry-point))))))
    3698            build-args)))
     3868    #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
     3869    #+ecl
     3870    (progn
     3871      (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
     3872      (apply 'c::builder
     3873             kind (pathname destination)
     3874             :lisp-files object-files
     3875             :init-name (c::compute-init-name (or output-name destination) :kind kind)
     3876             :prologue-code prologue-code
     3877             :epilogue-code
     3878             `(progn
     3879                ,epilogue-code
     3880                ,@(when (eq kind :program)
     3881                    `((setf *image-dumped-p* :executable)
     3882                      (restore-image ;; default behavior would be (si::top-level)
     3883                       ,@(when preludep `(:prelude ',prelude))
     3884                       ,@(when entry-point-p `(:entry-point ',entry-point))))))
     3885             build-args))))
    36993886
    37003887
     
    38434030(with-upgradability ()
    38444031  (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
    3845  
     4032
    38464033  #-(or gcl2.6 genera)
    38474034  (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
     
    38814068    (declare (ignorable x))
    38824069    (slurp-stream-form stream :at at))
     4070
     4071  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
     4072    (declare (ignorable x))
     4073    (apply 'slurp-input-stream *standard-output* stream keys))
     4074
     4075  (defmethod slurp-input-stream ((pathname pathname) input
     4076                                 &key
     4077                                   (element-type *default-stream-element-type*)
     4078                                   (external-format *utf-8-external-format*)
     4079                                   (if-exists :rename-and-delete)
     4080                                   (if-does-not-exist :create)
     4081                                   buffer-size
     4082                                   linewise)
     4083    (with-output-file (output pathname
     4084                              :element-type element-type
     4085                              :external-format external-format
     4086                              :if-exists if-exists
     4087                              :if-does-not-exist if-does-not-exist)
     4088      (copy-stream-to-stream
     4089       input output
     4090       :element-type element-type :buffer-size buffer-size :linewise linewise)))
    38834091
    38844092  (defmethod slurp-input-stream (x stream
     
    39194127    "Run program specified by COMMAND,
    39204128either a list of strings specifying a program and list of arguments,
    3921 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
    3922 have its output processed by the OUTPUT processor function
    3923 as per SLURP-INPUT-STREAM,
    3924 or merely output to the inherited standard output if it's NIL.
     4129or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
     4130
    39254131Always call a shell (rather than directly execute the command)
    39264132if FORCE-SHELL is specified.
    3927 Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
    3928 is specified.
    3929 Return the exit status code of the process that was called.
     4133
     4134Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
     4135unless IGNORE-ERROR-STATUS is specified.
     4136
     4137If OUTPUT is either NIL or :INTERACTIVE, then
     4138return the exit status code of the process that was called.
     4139if it was NIL, the output is discarded;
     4140if it was :INTERACTIVE, the output and the input are inherited from the current process.
     4141
     4142Otherwise, the output will be processed by SLURP-INPUT-STREAM,
     4143using OUTPUT as the first argument, and return whatever it returns,
     4144e.g. using :OUTPUT :STRING will have it return the entire output stream as a string.
    39304145Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
     4146    ;; TODO: specially recognize :output pathname ?
    39314147    (declare (ignorable ignore-error-status element-type external-format))
    39324148    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
     
    39704186                          #+os-windows command
    39714187                          :input interactive :output (or (and pipe :stream) interactive) :wait wait
    3972                           #+os-windows :show-window #+os-windows (and pipe :hide))
     4188                          #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
    39734189                         #+clisp
    39744190                         (flet ((run (f &rest args)
     
    39964212                                 #+sbcl '(:search t :external-format external-format)))))
    39974213                      (process
    3998                         #+(or allegro lispworks) (if pipe (third process*) (first process*))
     4214                        #+allegro (if pipe (third process*) (first process*))
    39994215                        #+ecl (third process*)
    4000                         #-(or allegro lispworks ecl) (first process*))
     4216                        #-(or allegro ecl) (first process*))
    40014217                      (stream
    40024218                        (when pipe
     
    40214237               #+(or cmu scl) (ext:process-exit-code process)
    40224238               #+ecl (nth-value 1 (ext:external-process-status process))
    4023                #+lispworks (if pipe (system:pid-exit-status process :wait t) process)
     4239               #+lispworks (if pipe (system:pipe-exit-status process :wait t) process)
    40244240               #+sbcl (sb-ext:process-exit-code process))
    40254241             (check-result (exit-code process)
     
    40604276               #+(or abcl xcl) (ext:run-shell-command command)
    40614277               #+allegro
    4062                (excl:run-shell-command command :input interactive :output interactive :wait t)
     4278               (excl:run-shell-command
     4279                command :input interactive :output interactive :wait t
     4280                        #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
    40634281               #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
    40644282               (process-result (run-program command :pipe nil :interactive interactive) nil)
     
    40684286               #+(and lispworks os-windows)
    40694287               (system:call-system-showing-output
    4070                 command :show-cmd interactive :prefix "" :output-stream nil)
     4288                command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil)
    40714289               #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
    40724290               #+mkcl (nth-value 2
     
    41104328   #:compile-warned-warning #:compile-failed-warning
    41114329   #:check-lisp-compile-results #:check-lisp-compile-warnings
    4112    #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
     4330   #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
     4331   ;; Types
     4332   #+sbcl #:sb-grovel-unknown-constant-condition
    41134333   ;; Functions & Macros
    41144334   #:get-optimization-settings #:proclaim-optimization-settings
     
    41164336   #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
    41174337   #:reify-simple-sexp #:unreify-simple-sexp
    4118    #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
     4338   #:reify-deferred-warnings #:unreify-deferred-warnings
    41194339   #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
    41204340   #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
     
    41474367  (defun get-optimization-settings ()
    41484368    "Get current compiler optimization settings, ready to PROCLAIM again"
     4369    #-(or clisp clozure cmu ecl sbcl scl)
     4370    (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
     4371    #+clozure (ccl:declaration-information 'optimize nil)
     4372    #+(or clisp cmu ecl sbcl scl)
    41494373    (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
    4150       #-(or clisp clozure cmu ecl sbcl scl)
    4151       (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
    41524374      #.`(loop :for x :in settings
    4153                ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
    4154                      #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
     4375               ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
    41554376                     #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
    41564377               :for y = (or #+clisp (gethash x system::*optimize*)
    4157                             #+(or clozure ecl) (symbol-value v)
     4378                            #+(or ecl) (symbol-value v)
    41584379                            #+(or cmu scl) (funcall f c::*default-cookie*)
    41594380                            #+sbcl (cdr (assoc x sb-c::*policy*)))
     
    41804401      '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
    41814402
    4182   (defvar *uninteresting-compiler-conditions*
     4403  (defvar *usual-uninteresting-conditions*
    41834404    (append
    41844405     ;;#+clozure '(ccl:compiler-warning)
     
    41894410     '(sb-c::simple-compiler-note
    41904411       "&OPTIONAL and &KEY found in the same lambda list: ~S"
     4412       #+sb-eval sb-kernel:lexical-environment-too-complex
     4413       sb-kernel:undefined-alien-style-warning
     4414       sb-grovel-unknown-constant-condition ; defined above.
     4415       sb-ext:implicit-generic-function-warning ;; Controversial.
    41914416       sb-int:package-at-variance
    41924417       sb-kernel:uninteresting-redefinition
    4193        sb-kernel:undefined-alien-style-warning
    4194        ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default.
    4195        #+sb-eval sb-kernel:lexical-environment-too-complex
    4196        sb-grovel-unknown-constant-condition ; defined above.
    41974418       ;; BEWARE: the below four are controversial to include here.
    41984419       sb-kernel:redefinition-with-defun
     
    42014422       sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
    42024423     '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
    4203     "Conditions that may be skipped while compiling")
    4204 
     4424    "A suggested value to which to set or bind *uninteresting-conditions*.")
     4425
     4426  (defvar *uninteresting-conditions* '()
     4427    "Conditions that may be skipped while compiling or loading Lisp code.")
     4428  (defvar *uninteresting-compiler-conditions* '()
     4429    "Additional conditions that may be skipped while compiling Lisp code.")
    42054430  (defvar *uninteresting-loader-conditions*
    42064431    (append
     
    42084433       #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
    42094434     #+clisp '(clos::simple-gf-replacing-method-warning))
    4210     "Additional conditions that may be skipped while loading"))
     4435    "Additional conditions that may be skipped while loading Lisp code."))
    42114436
    42124437;;;; ----- Filtering conditions while building -----
     
    42144439  (defun call-with-muffled-compiler-conditions (thunk)
    42154440    (call-with-muffled-conditions
    4216      thunk *uninteresting-compiler-conditions*))
     4441     thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
    42174442  (defmacro with-muffled-compiler-conditions ((&optional) &body body)
    42184443    "Run BODY where uninteresting compiler conditions are muffled"
     
    42204445  (defun call-with-muffled-loader-conditions (thunk)
    42214446    (call-with-muffled-conditions
    4222      thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
     4447     thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
    42234448  (defmacro with-muffled-loader-conditions ((&optional) &body body)
    42244449    "Run BODY where uninteresting compiler and additional loader conditions are muffled"
     
    43234548    (defun reify-function-name (function-name)
    43244549      (let ((name (or (first function-name) ;; defun: extract the name
    4325                       (first (second function-name))))) ;; defmethod: keep gf name, drop method specializers
     4550                      (let ((sec (second function-name)))
     4551                        (or (and (atom sec) sec) ; scoped method: drop scope
     4552                            (first sec)))))) ; method: keep gf name, drop method specializers
    43264553        (list name)))
    43274554    (defun unreify-function-name (function-name)
    43284555      function-name)
     4556    (defun nullify-non-literals (sexp)
     4557      (typecase sexp
     4558        ((or number character simple-string symbol pathname) sexp)
     4559        (cons (cons (nullify-non-literals (car sexp))
     4560                    (nullify-non-literals (cdr sexp))))
     4561        (t nil)))
    43294562    (defun reify-deferred-warning (deferred-warning)
    43304563      (with-accessors ((warning-type ccl::compiler-warning-warning-type)
     
    43344567        (list :warning-type warning-type :function-name (reify-function-name function-name)
    43354568              :source-note (reify-source-note source-note)
    4336               :args (destructuring-bind (fun formals env) args
    4337                       (declare (ignorable env))
    4338                       (list (unsymbolify-function-name fun)
    4339                             (mapcar (constantly nil) formals)
    4340                             nil)))))
     4569              :args (destructuring-bind (fun &rest more)
     4570                        args
     4571                      (cons (unsymbolify-function-name fun)
     4572                            (nullify-non-literals more))))))
    43414573    (defun unreify-deferred-warning (reified-deferred-warning)
    43424574      (destructuring-bind (&key warning-type function-name source-note args)
     
    43474579                        :source-note (unreify-source-note source-note)
    43484580                        :warning-type warning-type
    4349                         :args (destructuring-bind (fun . formals) args
    4350                                 (cons (symbolify-function-name fun) formals))))))
     4581                        :args (destructuring-bind (fun . more) args
     4582                                (cons (symbolify-function-name fun) more))))))
    43514583  #+(or cmu scl)
    43524584  (defun reify-undefined-warning (warning)
     
    47544986(with-upgradability ()
    47554987  (defun combine-fasls (inputs output)
    4756     #-(or allegro clisp clozure cmu lispworks sbcl scl xcl)
     4988    #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl)
    47574989    (error "~A does not support ~S~%inputs ~S~%output  ~S"
    47584990           (implementation-type) 'combine-fasls inputs output)
     4991    #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
     4992    #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
    47594993    #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
    4760     #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
    47614994    #+lispworks
    47624995    (let (fasls)
     
    47675000                   :for f = (add-pathname-suffix
    47685001                             output (format nil "-FASL~D" n))
    4769                    :do #-lispworks-personal-edition (lispworks:copy-file i f)
    4770                    #+lispworks-personal-edition (concatenate-files (list i) f)
    4771                                                 (push f fasls))
     5002                   :do (copy-file i f)
     5003                       (push f fasls))
    47725004             (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
    47735005             (eval `(scm:defsystem :fasls-to-concatenate
     
    47875019  (:recycle :uiop/configuration :asdf/configuration :asdf)
    47885020  (:use :uiop/common-lisp :uiop/utility
    4789    :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
     5021   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
    47905022  (:export
    47915023   #:get-folder-path
     
    47955027   #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
    47965028   #:configuration-inheritance-directive-p
    4797    #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
     5029   #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
    47985030   #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
    47995031   #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
     
    50135245       ((eql :home) (user-homedir-pathname))
    50145246       ((eql :here) (resolve-absolute-location
    5015                      *here-directory* :ensure-directory t :wilden nil))
     5247                     (or *here-directory* (pathname-directory-pathname (load-pathname)))
     5248                     :ensure-directory t :wilden nil))
    50165249       ((eql :user-cache) (resolve-absolute-location
    50175250                           *user-cache* :ensure-directory t :wilden nil)))
     
    51895422         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    51905423         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    5191          (asdf-version "2.32")
     5424         (asdf-version "3.0.1")
    51925425         (existing-version (asdf-version)))
    51935426    (setf *asdf-version* asdf-version)
     
    52065439             #:find-component ;; find-component
    52075440             #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
    5208              #:component-depends-on #:component-self-dependencies #:operation-done-p
     5441             #:component-depends-on #:operation-done-p #:component-depends-on
    52095442             #:traverse ;; plan
    52105443             #:operate  ;; operate
     
    52205453           '(#:*asdf-revision* #:around #:asdf-method-combination
    52215454             #:split #:make-collector #:do-dep #:do-one-dep
     5455             #:component-self-dependencies
    52225456             #:resolve-relative-location-component #:resolve-absolute-location-component
    52235457             #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
    52245458    (declare (ignorable redefined-functions uninterned-symbols))
    5225     (loop :for name :in (append #-(or ecl) redefined-functions)
     5459    (loop :for name :in (append redefined-functions)
    52265460          :for sym = (find-symbol* name :asdf nil) :do
    52275461            (when sym
    5228               (fmakunbound sym)))
     5462              ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
     5463              #-clisp (fmakunbound sym)))
    52295464    (loop :with asdf = (find-package :asdf)
    5230           :for name :in (append #+(or ecl) redefined-functions uninterned-symbols) ;XXX
     5465          :for name :in uninterned-symbols
    52315466          :for sym = (find-symbol* name :asdf nil)
    52325467          :for base-pkg = (and sym (symbol-package sym)) :do
     
    52905525   #:file-type
    52915526   #:source-file-type #:source-file-explicit-type ;; backward-compatibility
    5292    #:component-in-order-to #:component-sibling-dependencies
     5527   #:component-in-order-to #:component-sideway-dependencies
    52935528   #:component-if-feature #:around-compile-hook
    52945529   #:component-description #:component-long-description
     
    53095544   #:children #:children-by-name #:default-component-class
    53105545   #:author #:maintainer #:licence #:source-file #:defsystem-depends-on
    5311    #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
     5546   #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
    53125547   #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
    53135548   #:%encoding #:properties #:component-properties #:parent))
     
    53535588     (description :accessor component-description :initarg :description :initform nil)
    53545589     (long-description :accessor component-long-description :initarg :long-description :initform nil)
    5355      (sibling-dependencies :accessor component-sibling-dependencies :initform nil)
     5590     (sideway-dependencies :accessor component-sideway-dependencies :initform nil)
    53565591     (if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
    53575592     ;; In the ASDF object model, dependencies exist between *actions*,
     
    55485783
    55495784  (defmethod version-satisfies ((cver string) version)
    5550     (version-compatible-p cver version)))
     5785    (version<= version cver)))
    55515786
    55525787
     
    62896524  (:export
    62906525   #:operation
    6291    #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
     6526   #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
    62926527   #:build-op ;; THE generic operation
    62936528   #:*operations* #:make-operation #:find-operation #:feature))
     
    63556590   #:action #:define-convenience-action-methods
    63566591   #:explain #:action-description
    6357    #:downward-operation #:upward-operation #:sibling-operation
    6358    #:component-depends-on #:component-self-dependencies
     6592   #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
     6593   #:component-depends-on
    63596594   #:input-files #:output-files #:output-file #:operation-done-p
    63606595   #:action-status #:action-stamp #:action-done-p
     
    64346669;;;; Dependencies
    64356670(with-upgradability ()
    6436   (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
     6671  (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies
    64376672    (:documentation
    64386673     "Returns a list of dependencies needed by the component to perform
     
    64526687    Methods specialized on subclasses of existing component types
    64536688    should usually append the results of CALL-NEXT-METHOD to the list."))
    6454   (defgeneric component-self-dependencies (operation component))
    64556689  (define-convenience-action-methods component-depends-on (operation component))
    6456   (define-convenience-action-methods component-self-dependencies (operation component))
     6690
     6691  (defmethod component-depends-on :around ((o operation) (c component))
     6692    (do-asdf-cache `(component-depends-on ,o ,c)
     6693      (call-next-method)))
    64576694
    64586695  (defmethod component-depends-on ((o operation) (c component))
    6459     (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
    6460 
    6461   (defmethod component-self-dependencies ((o operation) (c component))
    6462     ;; NB: result in the same format as component-depends-on
    6463     (loop* :for (o-spec . c-spec) :in (component-depends-on o c)
    6464            :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
    6465            :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep)))
    6466            :collect (list o-spec c))))
     6696    (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
     6697
    64676698
    64686699;;;; upward-operation, downward-operation
     
    64746705  (defclass downward-operation (operation)
    64756706    ((downward-operation
    6476       :initform nil :initarg :downward-operation :reader downward-operation)))
     6707      :initform nil :initarg :downward-operation :reader downward-operation :allocation :class)))
    64776708  (defmethod component-depends-on ((o downward-operation) (c parent-component))
    64786709    `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
     
    64826713  (defclass upward-operation (operation)
    64836714    ((upward-operation
    6484       :initform nil :initarg :downward-operation :reader upward-operation)))
     6715      :initform nil :initarg :downward-operation :reader upward-operation :allocation :class)))
    64856716  ;; For backward-compatibility reasons, a system inherits from module and is a child-component
    64866717  ;; so we must guard against this case. ASDF4: remove that.
     
    64916722  ;; operation on a child depends-on operation on its parent.
    64926723  ;; By default, an operation propagates itself, but it may propagate another one instead.
    6493   (defclass sibling-operation (operation)
    6494     ((sibling-operation
    6495       :initform nil :initarg :sibling-operation :reader sibling-operation)))
    6496   (defmethod component-depends-on ((o sibling-operation) (c component))
    6497     `((,(or (sibling-operation o) o)
    6498        ,@(loop :for dep :in (component-sibling-dependencies c)
     6724  (defclass sideway-operation (operation)
     6725    ((sideway-operation
     6726      :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class)))
     6727  (defmethod component-depends-on ((o sideway-operation) (c component))
     6728    `((,(or (sideway-operation o) o)
     6729       ,@(loop :for dep :in (component-sideway-dependencies c)
    64996730               :collect (resolve-dependency-spec c dep)))
     6731      ,@(call-next-method)))
     6732  ;; Selfward operations propagate to themselves a sub-operation:
     6733  ;; they depend on some other operation being acted on the same component.
     6734  (defclass selfward-operation (operation)
     6735    ((selfward-operation
     6736      :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class)))
     6737  (defmethod component-depends-on ((o selfward-operation) (c component))
     6738    `(,@(loop :for op :in (ensure-list (selfward-operation o))
     6739              :collect `(,op ,c))
    65006740      ,@(call-next-method))))
    65016741
     
    65476787      (call-next-method)))
    65486788
    6549   (defmethod input-files ((o operation) (c parent-component))
     6789  (defmethod input-files ((o operation) (c component))
    65506790    (declare (ignorable o c))
    65516791    nil)
    65526792
    6553   (defmethod input-files ((o operation) (c component))
    6554     (or (loop* :for (dep-o) :in (component-self-dependencies o c)
    6555                :append (or (output-files dep-o c) (input-files dep-o c)))
    6556         ;; no non-trivial previous operations needed?
    6557         ;; I guess we work with the original source file, then
    6558         (if-let ((pathname (component-pathname c)))
    6559           (and (file-pathname-p pathname) (list pathname))))))
     6793  (defmethod input-files ((o selfward-operation) (c component))
     6794    `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
     6795                  :append (or (output-files dep-o c) (input-files dep-o c)))
     6796            (if-let ((pathname (component-pathname c)))
     6797              (and (file-pathname-p pathname) (list pathname))))
     6798      ,@(call-next-method))))
    65606799
    65616800
     
    66646903   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
    66656904   #:call-with-around-compile-hook
    6666    #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags))
     6905   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
     6906   #:lisp-compilation-output-files #:flags))
    66676907(in-package :asdf/lisp-action)
    66686908
     
    66886928;;; Our default operations: loading into the current lisp image
    66896929(with-upgradability ()
    6690   (defclass load-op (basic-load-op downward-operation sibling-operation) ())
    6691   (defclass prepare-op (upward-operation sibling-operation)
    6692     ((sibling-operation :initform 'load-op :allocation :class)))
    6693   (defclass compile-op (basic-compile-op downward-operation)
    6694     ((downward-operation :initform 'load-op :allocation :class)))
    6695 
    6696   (defclass load-source-op (basic-load-op downward-operation) ())
    6697   (defclass prepare-source-op (upward-operation sibling-operation)
    6698     ((sibling-operation :initform 'load-source-op :allocation :class)))
    6699 
    6700   (defclass test-op (operation) ()))
     6930  (defclass prepare-op (upward-operation sideway-operation)
     6931    ((sideway-operation :initform 'load-op)))
     6932  (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
     6933    ;; NB: even though compile-op depends-on on prepare-op it is not needed-in-image-p,
     6934    ;; so we need to directly depend on prepare-op for its side-effects in the current image.
     6935    ((selfward-operation :initform '(prepare-op compile-op))))
     6936  (defclass compile-op (basic-compile-op downward-operation selfward-operation)
     6937    ((selfward-operation :initform 'prepare-op)
     6938     (downward-operation :initform 'load-op)))
     6939
     6940  (defclass prepare-source-op (upward-operation sideway-operation)
     6941    ((sideway-operation :initform 'load-source-op)))
     6942  (defclass load-source-op (basic-load-op downward-operation selfward-operation)
     6943    ((selfward-operation :initform 'prepare-source-op)))
     6944
     6945  (defclass test-op (selfward-operation)
     6946    ((selfward-operation :initform 'load-op))))
    67016947
    67026948
     
    67747020  (defmethod perform ((o compile-op) (c cl-source-file))
    67757021    (perform-lisp-compilation o c))
    6776   (defmethod output-files ((o compile-op) (c cl-source-file))
    6777     (declare (ignorable o))
     7022  (defun lisp-compilation-output-files (o c)
    67787023    (let* ((i (first (input-files o c)))
    67797024           (f (compile-file-pathname
     
    67897034        ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
    67907035            `(,(make-pathname :type *warnings-file-type* :defaults f))))))
    6791   (defmethod component-depends-on ((o compile-op) (c component))
    6792     (declare (ignorable o))
    6793     `((prepare-op ,c) ,@(call-next-method)))
     7036  (defmethod output-files ((o compile-op) (c cl-source-file))
     7037    (lisp-compilation-output-files o c))
    67947038  (defmethod perform ((o compile-op) (c static-file))
    67957039    (declare (ignorable o c))
     
    68417085  (defmethod perform ((o load-op) (c static-file))
    68427086    (declare (ignorable o c))
    6843     nil)
    6844   (defmethod component-depends-on ((o load-op) (c component))
    6845     (declare (ignorable o))
    6846     ;; NB: even though compile-op depends-on on prepare-op,
    6847     ;; it is not needed-in-image-p, whereas prepare-op is,
    6848     ;; so better not omit prepare-op and think it will happen.
    6849     `((prepare-op ,c) (compile-op ,c) ,@(call-next-method))))
     7087    nil))
    68507088
    68517089
     
    68757113    (declare (ignorable o))
    68767114    (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
    6877   (defmethod component-depends-on ((o load-source-op) (c component))
    6878     (declare (ignorable o))
    6879     `((prepare-source-op ,c) ,@(call-next-method)))
    68807115  (defun perform-lisp-load-source (o c)
    68817116    (call-with-around-compile-hook
     
    69037138    "Testing a system is _never_ done."
    69047139    (declare (ignorable o c))
    6905     nil)
    6906   (defmethod component-depends-on ((o test-op) (c system))
    6907     (declare (ignorable o))
    6908     `((load-op ,c) ,@(call-next-method))))
    6909 
     7140    nil))
    69107141
    69117142;;;; -------------------------------------------------------------------------
     
    71527383          (values done-stamp ;; return the hard-earned timestamp
    71537384                  (or just-done
    7154                       (or out-op ;; a file-creating op is done when all files are up to date
    7155                           ;; a image-effecting a placeholder op is done when it was actually run,
    7156                           (and op-time (eql op-time done-stamp))))) ;; with the matching stamp
     7385                      out-op ;; a file-creating op is done when all files are up to date
     7386                      ;; a image-effecting a placeholder op is done when it was actually run,
     7387                      (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
    71577388          ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
    71587389          (values t nil)))))
     
    72817512  (defgeneric plan-operates-on-p (plan component))
    72827513
    7283   (defparameter *default-plan-class* 'sequential-plan)
     7514  (defvar *default-plan-class* 'sequential-plan)
    72847515
    72857516  (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
     
    72977528        (call-next-method))))   ;; Going forward, see deferred-warning support in lisp-build.
    72987529
    7299   (defmethod perform-plan ((steps list) &key)
    7300     (loop* :for (op . component) :in steps :do
    7301            (perform-with-restarts op component)))
     7530  (defmethod perform-plan ((steps list) &key force &allow-other-keys)
     7531    (loop* :for (o . c) :in steps
     7532           :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
     7533           :do (perform-with-restarts o c)))
    73027534
    73037535  (defmethod plan-operates-on-p ((plan list) (component-path list))
     
    73487580  (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
    73497581    (remove-duplicates
    7350      (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys))
     7582     (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system
     7583                         (remove-plist-key :goal-operation keys)))
    73517584     :from-end t)))
    73527585
     
    74417674                      &rest keys &key &allow-other-keys)
    74427675    (let ((plan (apply 'traverse operation component keys)))
    7443       (perform-plan plan)
     7676      (apply 'perform-plan plan keys)
    74447677      (values operation plan)))
    74457678
     
    75637796  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
    75647797
     7798
     7799;;;; -------------------------------------------------------------------------
     7800;;; Internal hacks for backward-compatibility
     7801
     7802(asdf/package:define-package :asdf/backward-internals
     7803  (:recycle :asdf/backward-internals :asdf)
     7804  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
     7805   :asdf/system :asdf/component :asdf/operation
     7806   :asdf/find-system :asdf/action :asdf/lisp-action)
     7807  (:export ;; for internal use
     7808   #:load-sysdef #:make-temporary-package
     7809   #:%refresh-component-inline-methods
     7810   #:%resolve-if-component-dep-fails
     7811   #:make-sub-operation
     7812   #:load-sysdef #:make-temporary-package))
     7813(in-package :asdf/backward-internals)
     7814
     7815;;;; Backward compatibility with "inline methods"
     7816(with-upgradability ()
     7817  (defparameter +asdf-methods+
     7818    '(perform-with-restarts perform explain output-files operation-done-p))
     7819
     7820  (defun %remove-component-inline-methods (component)
     7821    (dolist (name +asdf-methods+)
     7822      (map ()
     7823           ;; this is inefficient as most of the stored
     7824           ;; methods will not be for this particular gf
     7825           ;; But this is hardly performance-critical
     7826           #'(lambda (m)
     7827               (remove-method (symbol-function name) m))
     7828           (component-inline-methods component)))
     7829    (component-inline-methods component) nil)
     7830
     7831  (defun %define-component-inline-methods (ret rest)
     7832    (loop* :for (key value) :on rest :by #'cddr
     7833           :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
     7834           :when name :do
     7835           (destructuring-bind (op &rest body) value
     7836             (loop :for arg = (pop body)
     7837                   :while (atom arg)
     7838                   :collect arg :into qualifiers
     7839                   :finally
     7840                      (destructuring-bind (o c) arg
     7841                        (pushnew
     7842                         (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
     7843                         (component-inline-methods ret)))))))
     7844
     7845  (defun %refresh-component-inline-methods (component rest)
     7846    ;; clear methods, then add the new ones
     7847    (%remove-component-inline-methods component)
     7848    (%define-component-inline-methods component rest)))
     7849
     7850;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
     7851;; and the companion asdf:feature pseudo-dependency.
     7852;; This won't recurse into dependencies to accumulate feature conditions.
     7853;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
     7854;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
     7855(with-upgradability ()
     7856  (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
     7857    (asdf-message "The system definition for ~S uses deprecated ~
     7858                 ASDF option :IF-COMPONENT-DEP-DAILS. ~
     7859                 Starting with ASDF 3, please use :IF-FEATURE instead"
     7860                  (coerce-name (component-system component)))
     7861    ;; This only supports the pattern of use of the "feature" seen in the wild
     7862    (check-type component parent-component)
     7863    (check-type if-component-dep-fails (member :fail :ignore :try-next))
     7864    (unless (eq if-component-dep-fails :fail)
     7865      (loop :with o = (make-operation 'compile-op)
     7866            :for c :in (component-children component) :do
     7867              (loop* :for (feature? feature) :in (component-depends-on o c)
     7868                     :when (eq feature? 'feature) :do
     7869                     (setf (component-if-feature c) feature))))))
     7870
     7871(when-upgrading (:when (fboundp 'make-sub-operation))
     7872  (defun make-sub-operation (c o dep-c dep-o)
     7873    (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
     7874
     7875
     7876;;;; load-sysdef
     7877(with-upgradability ()
     7878  (defun load-sysdef (name pathname)
     7879    (load-asd pathname :name name))
     7880
     7881  (defun make-temporary-package ()
     7882    ;; For loading a .asd file, we dont't make a temporary package anymore,
     7883    ;; but use ASDF-USER. I'd like to have this function do this,
     7884    ;; but since whoever uses it is likely to delete-package the result afterwards,
     7885    ;; this would be a bad idea, so preserve the old behavior.
     7886    (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
     7887
     7888
     7889;;;; -------------------------------------------------------------------------
     7890;;;; Defsystem
     7891
     7892(asdf/package:define-package :asdf/defsystem
     7893  (:recycle :asdf/defsystem :asdf)
     7894  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
     7895   :asdf/component :asdf/system :asdf/cache
     7896   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
     7897   :asdf/backward-internals)
     7898  (:export
     7899   #:defsystem #:register-system-definition
     7900   #:class-for-type #:*default-component-class*
     7901   #:determine-system-directory #:parse-component-form
     7902   #:duplicate-names #:non-toplevel-system #:non-system-system
     7903   #:sysdef-error-component #:check-component-input))
     7904(in-package :asdf/defsystem)
     7905
     7906;;; Pathname
     7907(with-upgradability ()
     7908  (defun determine-system-directory (pathname)
     7909    ;; The defsystem macro calls this function to determine
     7910    ;; the pathname of a system as follows:
     7911    ;; 1. if the pathname argument is an pathname object (NOT a namestring),
     7912    ;;    that is already an absolute pathname, return it.
     7913    ;; 2. otherwise, the directory containing the LOAD-PATHNAME
     7914    ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
     7915    ;;    if it is indeed available and an absolute pathname, then
     7916    ;;    the PATHNAME argument is normalized to a relative pathname
     7917    ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
     7918    ;;    and merged into that DIRECTORY as per SUBPATHNAME.
     7919    ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
     7920    ;;    and may be from within the EVAL-WHEN of a file compilation.
     7921    ;; If no absolute pathname was found, we return NIL.
     7922    (check-type pathname (or null string pathname))
     7923    (pathname-directory-pathname
     7924     (resolve-symlinks*
     7925      (ensure-absolute-pathname
     7926       (parse-unix-namestring pathname :type :directory)
     7927       #'(lambda () (ensure-absolute-pathname
     7928                     (load-pathname) 'get-pathname-defaults nil))
     7929       nil)))))
     7930
     7931
     7932;;; Component class
     7933(with-upgradability ()
     7934  (defvar *default-component-class* 'cl-source-file)
     7935
     7936  (defun class-for-type (parent type)
     7937    (or (loop :for symbol :in (list
     7938                               type
     7939                               (find-symbol* type *package* nil)
     7940                               (find-symbol* type :asdf/interface nil)
     7941                               (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
     7942              :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
     7943              :when (and class
     7944                         (#-cormanlisp subtypep #+cormanlisp cl::subclassp
     7945                          class (find-class* 'component)))
     7946                :return class)
     7947        (and (eq type :file)
     7948             (find-class*
     7949              (or (loop :for p = parent :then (component-parent p) :while p
     7950                        :thereis (module-default-component-class p))
     7951                  *default-component-class*) nil))
     7952        (sysdef-error "don't recognize component type ~A" type))))
     7953
     7954
     7955;;; Check inputs
     7956(with-upgradability ()
     7957  (define-condition duplicate-names (system-definition-error)
     7958    ((name :initarg :name :reader duplicate-names-name))
     7959    (:report (lambda (c s)
     7960               (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
     7961                       (duplicate-names-name c)))))
     7962
     7963  (define-condition non-system-system (system-definition-error)
     7964    ((name :initarg :name :reader non-system-system-name)
     7965     (class-name :initarg :class-name :reader non-system-system-class-name))
     7966    (:report (lambda (c s)
     7967               (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
     7968                       (non-system-system-name c) (non-system-system-class-name c) 'system))))
     7969
     7970  (define-condition non-toplevel-system (system-definition-error)
     7971    ((parent :initarg :parent :reader non-toplevel-system-parent)
     7972     (name :initarg :name :reader non-toplevel-system-name))
     7973    (:report (lambda (c s)
     7974               (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
     7975                       (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
     7976
     7977  (defun sysdef-error-component (msg type name value)
     7978    (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
     7979                  type name value))
     7980
     7981  (defun check-component-input (type name weakly-depends-on
     7982                                depends-on components)
     7983    "A partial test of the values of a component."
     7984    (unless (listp depends-on)
     7985      (sysdef-error-component ":depends-on must be a list."
     7986                              type name depends-on))
     7987    (unless (listp weakly-depends-on)
     7988      (sysdef-error-component ":weakly-depends-on must be a list."
     7989                              type name weakly-depends-on))
     7990    (unless (listp components)
     7991      (sysdef-error-component ":components must be NIL or a list of components."
     7992                              type name components)))
     7993
     7994  (defun* (normalize-version) (form &key pathname component parent)
     7995    (labels ((invalid (&optional (continuation "using NIL instead"))
     7996               (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
     7997                     form component parent pathname continuation))
     7998             (invalid-parse (control &rest args)
     7999               (unless (builtin-system-p (find-component parent component))
     8000                 (apply 'warn control args)
     8001                 (invalid))))
     8002      (if-let (v (typecase form
     8003                   ((or string null) form)
     8004                   (real
     8005                    (invalid "Substituting a string")
     8006                    (format nil "~D" form)) ;; 1.0 becomes "1.0"
     8007                   (cons
     8008                    (case (first form)
     8009                      ((:read-file-form)
     8010                       (destructuring-bind (subpath &key (at 0)) (rest form)
     8011                         (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
     8012                      ((:read-file-line)
     8013                       (destructuring-bind (subpath &key (at 0)) (rest form)
     8014                         (read-file-lines (subpathname pathname subpath) :at at)))
     8015                      (otherwise
     8016                       (invalid))))
     8017                   (t
     8018                    (invalid))))
     8019        (if-let (pv (parse-version v #'invalid-parse))
     8020          (unparse-version pv)
     8021          (invalid))))))
     8022
     8023
     8024;;; Main parsing function
     8025(with-upgradability ()
     8026  (defun* (parse-component-form) (parent options &key previous-serial-component)
     8027    (destructuring-bind
     8028        (type name &rest rest &key
     8029                                (builtin-system-p () bspp)
     8030                                ;; the following list of keywords is reproduced below in the
     8031                                ;; remove-plist-keys form.  important to keep them in sync
     8032                                components pathname perform explain output-files operation-done-p
     8033                                weakly-depends-on depends-on serial
     8034                                do-first if-component-dep-fails version
     8035                                ;; list ends
     8036         &allow-other-keys) options
     8037      (declare (ignorable perform explain output-files operation-done-p builtin-system-p))
     8038      (check-component-input type name weakly-depends-on depends-on components)
     8039      (when (and parent
     8040                 (find-component parent name)
     8041                 (not ;; ignore the same object when rereading the defsystem
     8042                  (typep (find-component parent name)
     8043                         (class-for-type parent type))))
     8044        (error 'duplicate-names :name name))
     8045      (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
     8046      (let* ((name (coerce-name name))
     8047             (args `(:name ,name
     8048                     :pathname ,pathname
     8049                     ,@(when parent `(:parent ,parent))
     8050                     ,@(remove-plist-keys
     8051                        '(:components :pathname :if-component-dep-fails :version
     8052                          :perform :explain :output-files :operation-done-p
     8053                          :weakly-depends-on :depends-on :serial)
     8054                        rest)))
     8055             (component (find-component parent name))
     8056             (class (class-for-type parent type)))
     8057        (when (and parent (subtypep class 'system))
     8058          (error 'non-toplevel-system :parent parent :name name))
     8059        (if component ; preserve identity
     8060            (apply 'reinitialize-instance component args)
     8061            (setf component (apply 'make-instance class args)))
     8062        (component-pathname component) ; eagerly compute the absolute pathname
     8063        (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
     8064          (when (and (typep component 'system) (not bspp))
     8065            (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
     8066          (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
     8067        ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
     8068        ;; A better fix is required.
     8069        (setf (slot-value component 'version) version)
     8070        (when (typep component 'parent-component)
     8071          (setf (component-children component)
     8072                (loop
     8073                  :with previous-component = nil
     8074                  :for c-form :in components
     8075                  :for c = (parse-component-form component c-form
     8076                                                 :previous-serial-component previous-component)
     8077                  :for name = (component-name c)
     8078                  :collect c
     8079                  :when serial :do (setf previous-component name)))
     8080          (compute-children-by-name component))
     8081        (when previous-serial-component
     8082          (push previous-serial-component depends-on))
     8083        (when weakly-depends-on
     8084          ;; ASDF4: deprecate this feature and remove it.
     8085          (appendf depends-on
     8086                   (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
     8087        ;; Used by POIU. ASDF4: rename to component-depends-on?
     8088        (setf (component-sideway-dependencies component) depends-on)
     8089        (%refresh-component-inline-methods component rest)
     8090        (when if-component-dep-fails
     8091          (%resolve-if-component-dep-fails if-component-dep-fails component))
     8092        component)))
     8093
     8094  (defun register-system-definition
     8095      (name &rest options &key pathname (class 'system) (source-file () sfp)
     8096                            defsystem-depends-on &allow-other-keys)
     8097    ;; The system must be registered before we parse the body,
     8098    ;; otherwise we recur when trying to find an existing system
     8099    ;; of the same name to reuse options (e.g. pathname) from.
     8100    ;; To avoid infinite recursion in cases where you defsystem a system
     8101    ;; that is registered to a different location to find-system,
     8102    ;; we also need to remember it in a special variable *systems-being-defined*.
     8103    (with-system-definitions ()
     8104      (let* ((name (coerce-name name))
     8105             (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
     8106             (registered (system-registered-p name))
     8107             (registered! (if registered
     8108                              (rplaca registered (get-file-stamp source-file))
     8109                              (register-system
     8110                               (make-instance 'system :name name :source-file source-file))))
     8111             (system (reset-system (cdr registered!)
     8112                                   :name name :source-file source-file))
     8113             (component-options (remove-plist-key :class options))
     8114             (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
     8115                                           (resolve-dependency-spec nil spec))))
     8116        (setf (gethash name *systems-being-defined*) system)
     8117        (apply 'load-systems defsystem-dependencies)
     8118        ;; We change-class AFTER we loaded the defsystem-depends-on
     8119        ;; since the class might be defined as part of those.
     8120        (let ((class (class-for-type nil class)))
     8121          (unless (subtypep class 'system)
     8122            (error 'non-system-system :name name :class-name (class-name class)))
     8123          (unless (eq (type-of system) class)
     8124            (change-class system class)))
     8125        (parse-component-form
     8126         nil (list*
     8127              :module name
     8128              :pathname (determine-system-directory pathname)
     8129              component-options)))))
     8130
     8131  (defmacro defsystem (name &body options)
     8132    `(apply 'register-system-definition ',name ',options)))
     8133;;;; -------------------------------------------------------------------------
     8134;;;; ASDF-Bundle
     8135
     8136(asdf/package:define-package :asdf/bundle
     8137  (:recycle :asdf/bundle :asdf)
     8138  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
     8139   :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
     8140   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
     8141  (:export
     8142   #:bundle-op #:bundle-op-build-args #:bundle-type
     8143   #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
     8144   #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
     8145   #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
     8146   #:lib-op #:monolithic-lib-op
     8147   #:dll-op #:monolithic-dll-op
     8148   #:binary-op #:monolithic-binary-op
     8149   #:program-op #:compiled-file #:precompiled-system #:prebuilt-system
     8150   #:user-system-p #:user-system #:trivial-system-p
     8151   #+ecl #:make-build
     8152   #:register-pre-built-system
     8153   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
     8154(in-package :asdf/bundle)
     8155
     8156(with-upgradability ()
     8157  (defclass bundle-op (operation)
     8158    ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
     8159     (name-suffix :initarg :name-suffix :initform nil)
     8160     (bundle-type :initform :no-output-file :reader bundle-type)
     8161     #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
     8162     #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
     8163     #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
     8164
     8165  (defclass bundle-compile-op (bundle-op basic-compile-op)
     8166    ()
     8167    (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))
     8168
     8169  ;; create a single fasl for the entire library
     8170  (defclass basic-fasl-op (bundle-compile-op)
     8171    ((bundle-type :initform :fasl)))
     8172  (defclass prepare-fasl-op (sideway-operation)
     8173    ((sideway-operation :initform 'load-fasl-op)))
     8174  (defclass fasl-op (basic-fasl-op selfward-operation)
     8175    ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op))))
     8176  (defclass load-fasl-op (basic-load-op selfward-operation)
     8177    ((selfward-operation :initform '(prepare-op fasl-op))))
     8178
     8179  ;; NB: since the monolithic-op's can't be sideway-operation's,
     8180  ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's,
     8181  ;; we'd have to have the monolithic-op not inherit from the main op,
     8182  ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
     8183
     8184  (defclass lib-op (bundle-compile-op)
     8185    ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
     8186    (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
     8187     #-(or ecl mkcl) "just compile the system"))
     8188
     8189  (defclass dll-op (bundle-op basic-compile-op)
     8190    ((bundle-type :initform :dll))
     8191    (:documentation "Link together all the dynamic library used by this system into a single one."))
     8192
     8193  (defclass binary-op (basic-compile-op selfward-operation)
     8194    ((selfward-operation :initform '(fasl-op lib-op)))
     8195    (:documentation "produce fasl and asd files for the system"))
     8196
     8197  (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
     8198
     8199  (defclass monolithic-bundle-op (monolithic-op bundle-op)
     8200    ((prologue-code :accessor monolithic-op-prologue-code)
     8201     (epilogue-code :accessor monolithic-op-epilogue-code)))
     8202
     8203  (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op)
     8204    ()
     8205    (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems"))
     8206
     8207  (defclass monolithic-binary-op (monolithic-op binary-op)
     8208    ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op)))
     8209    (:documentation "produce fasl and asd files for combined system and dependencies."))
     8210
     8211  (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
     8212    (:documentation "Create a single fasl for the system and its dependencies."))
     8213
     8214  (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op)
     8215    ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
     8216    (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
     8217     #-(or ecl mkcl) "Compile a system and its dependencies."))
     8218
     8219  (defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
     8220    ((bundle-type :initform :dll)
     8221     (selfward-operation :initform 'dll-op)
     8222     (sideway-operation :initform 'dll-op)))
     8223
     8224  (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
     8225            #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
     8226    ((bundle-type :initform :program)
     8227     #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op))
     8228    (:documentation "create an executable file from the system and its dependencies"))
     8229
     8230  (defun bundle-pathname-type (bundle-type)
     8231    (etypecase bundle-type
     8232      ((eql :no-output-file) nil) ;; should we error out instead?
     8233      ((or null string) bundle-type)
     8234      ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
     8235      #+ecl
     8236      ((member :binary :dll :lib :static-library :program :object :program)
     8237       (compile-file-type :type bundle-type))
     8238      ((eql :binary) "image")
     8239      ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
     8240      ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
     8241      ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
     8242
     8243  (defun bundle-output-files (o c)
     8244    (when (input-files o c)
     8245      (let ((bundle-type (bundle-type o)))
     8246        (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
     8247          (let ((name (or (component-build-pathname c)
     8248                          (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
     8249                (type (bundle-pathname-type bundle-type)))
     8250            (values (list (subpathname (component-pathname c) name :type type))
     8251                    (eq (type-of o) (component-build-operation c))))))))
     8252
     8253  (defmethod output-files ((o bundle-op) (c system))
     8254    (bundle-output-files o c))
     8255
     8256  #-(or ecl mkcl)
     8257  (defmethod perform ((o program-op) (c system))
     8258    (let ((output-file (output-file o c)))
     8259      (setf *image-entry-point* (ensure-function (component-entry-point c)))
     8260      (dump-image output-file :executable t)))
     8261
     8262  (defclass compiled-file (file-component)
     8263    ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
     8264
     8265  (defclass precompiled-system (system)
     8266    ((build-pathname :initarg :fasl)))
     8267
     8268  (defclass prebuilt-system (system)
     8269    ((build-pathname :initarg :static-library :initarg :lib
     8270                     :accessor prebuilt-system-static-library))))
     8271
     8272
     8273;;;
     8274;;; BUNDLE-OP
     8275;;;
     8276;;; This operation takes all components from one or more systems and
     8277;;; creates a single output file, which may be
     8278;;; a FASL, a statically linked library, a shared library, etc.
     8279;;; The different targets are defined by specialization.
     8280;;;
     8281(with-upgradability ()
     8282  (defun operation-monolithic-p (op)
     8283    (typep op 'monolithic-op))
     8284
     8285  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
     8286                                         &key (name-suffix nil name-suffix-p)
     8287                                         &allow-other-keys)
     8288    (declare (ignorable initargs name-suffix))
     8289    (unless name-suffix-p
     8290      (setf (slot-value instance 'name-suffix)
     8291            (unless (typep instance 'program-op)
     8292              (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
     8293    (when (typep instance 'monolithic-bundle-op)
     8294      (destructuring-bind (&rest original-initargs
     8295                           &key lisp-files prologue-code epilogue-code
     8296                           &allow-other-keys)
     8297          (operation-original-initargs instance)
     8298        (setf (operation-original-initargs instance)
     8299              (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
     8300              (monolithic-op-prologue-code instance) prologue-code
     8301              (monolithic-op-epilogue-code instance) epilogue-code)
     8302        #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
     8303        #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
     8304    (setf (bundle-op-build-args instance)
     8305          (remove-plist-keys '(:type :monolithic :name-suffix)
     8306                             (operation-original-initargs instance))))
     8307
     8308  (defmethod bundle-op-build-args :around ((o lib-op))
     8309    (declare (ignorable o))
     8310    (let ((args (call-next-method)))
     8311      (remf args :ld-flags)
     8312      args))
     8313
     8314  (defun bundlable-file-p (pathname)
     8315    (let ((type (pathname-type pathname)))
     8316      (declare (ignorable type))
     8317      (or #+ecl (or (equalp type (compile-file-type :type :object))
     8318                    (equalp type (compile-file-type :type :static-library)))
     8319          #+mkcl (equalp type (compile-file-type :fasl-p nil))
     8320          #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
     8321
     8322  (defgeneric* (trivial-system-p) (component))
     8323
     8324  (defun user-system-p (s)
     8325    (and (typep s 'system)
     8326         (not (builtin-system-p s))
     8327         (not (trivial-system-p s)))))
     8328
     8329(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
     8330  (deftype user-system () '(and system (satisfies user-system-p))))
     8331
     8332;;;
     8333;;; First we handle monolithic bundles.
     8334;;; These are standalone systems which contain everything,
     8335;;; including other ASDF systems required by the current one.
     8336;;; A PROGRAM is always monolithic.
     8337;;;
     8338;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
     8339;;;
     8340(with-upgradability ()
     8341  (defmethod component-depends-on ((o bundle-compile-op) (c system))
     8342    `(,(if (operation-monolithic-p o)
     8343           `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
     8344               ,@(required-components c :other-systems t :component-type 'system
     8345                                        :goal-operation (find-operation o 'load-op)
     8346                                        :keep-operation 'compile-op))
     8347           `(compile-op
     8348             ,@(required-components c :other-systems nil :component-type '(not system)
     8349                                      :goal-operation (find-operation o 'load-op)
     8350                                      :keep-operation 'compile-op)))
     8351      ,@(call-next-method)))
     8352
     8353  (defmethod component-depends-on :around ((o bundle-op) (c component))
     8354    (declare (ignorable o c))
     8355    (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
     8356      `((,op ,c))
     8357      (call-next-method)))
     8358
     8359  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
     8360    ;; This file selects output files from direct dependencies;
     8361    ;; your component-depends-on method better gathered the correct dependencies in the correct order.
     8362    (while-collecting (collect)
     8363      (map-direct-dependencies
     8364       o c #'(lambda (sub-o sub-c)
     8365               (loop :for f :in (funcall key sub-o sub-c)
     8366                     :when (funcall test f) :do (collect f))))))
     8367
     8368  (defmethod input-files ((o bundle-compile-op) (c system))
     8369    (unless (eq (bundle-type o) :no-output-file)
     8370      (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
     8371
     8372  (defun select-bundle-operation (type &optional monolithic)
     8373    (ecase type
     8374      ((:binary)
     8375       (if monolithic 'monolithic-binary-op 'binary-op))
     8376      ((:dll :shared-library)
     8377       (if monolithic 'monolithic-dll-op 'dll-op))
     8378      ((:lib :static-library)
     8379       (if monolithic 'monolithic-lib-op 'lib-op))
     8380      ((:fasl)
     8381       (if monolithic 'monolithic-fasl-op 'fasl-op))
     8382      ((:program)
     8383       'program-op)))
     8384
     8385  (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
     8386                             (move-here nil move-here-p)
     8387                             &allow-other-keys)
     8388    (let* ((operation-name (select-bundle-operation type monolithic))
     8389           (move-here-path (if (and move-here
     8390                                    (typep move-here '(or pathname string)))
     8391                               (pathname move-here)
     8392                               (system-relative-pathname system "asdf-output/")))
     8393           (operation (apply #'operate operation-name
     8394                             system
     8395                             (remove-plist-keys '(:monolithic :type :move-here) args)))
     8396           (system (find-system system))
     8397           (files (and system (output-files operation system))))
     8398      (if (or move-here (and (null move-here-p)
     8399                             (member operation-name '(:program :binary))))
     8400          (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
     8401                :for f :in files
     8402                :for new-f = (make-pathname :name (pathname-name f)
     8403                                            :type (pathname-type f)
     8404                                            :defaults dest-path)
     8405                :do (rename-file-overwriting-target f new-f)
     8406                :collect new-f)
     8407          files))))
     8408
     8409;;;
     8410;;; LOAD-FASL-OP
     8411;;;
     8412;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
     8413;;;
     8414(with-upgradability ()
     8415  (defmethod component-depends-on ((o load-fasl-op) (c system))
     8416    (declare (ignorable o))
     8417    `((,o ,@(loop :for dep :in (component-sideway-dependencies c)
     8418                  :collect (resolve-dependency-spec c dep)))
     8419      (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
     8420      ,@(call-next-method)))
     8421
     8422  (defmethod input-files ((o load-fasl-op) (c system))
     8423    (when (user-system-p c)
     8424      (output-files (find-operation o 'fasl-op) c)))
     8425
     8426  (defmethod perform ((o load-fasl-op) c)
     8427    (declare (ignorable o c))
     8428    nil)
     8429
     8430  (defmethod perform ((o load-fasl-op) (c system))
     8431    (when (input-files o c)
     8432      (perform-lisp-load-fasl o c)))
     8433
     8434  (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
     8435    (mark-operation-done (find-operation o 'load-op) c)))
     8436
     8437;;;
     8438;;; PRECOMPILED FILES
     8439;;;
     8440;;; This component can be used to distribute ASDF systems in precompiled form.
     8441;;; Only useful when the dependencies have also been precompiled.
     8442;;;
     8443(with-upgradability ()
     8444  (defmethod trivial-system-p ((s system))
     8445    (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
     8446
     8447  (defmethod output-files (o (c compiled-file))
     8448    (declare (ignorable o c))
     8449    nil)
     8450  (defmethod input-files (o (c compiled-file))
     8451    (declare (ignorable o))
     8452    (component-pathname c))
     8453  (defmethod perform ((o load-op) (c compiled-file))
     8454    (perform-lisp-load-fasl o c))
     8455  (defmethod perform ((o load-source-op) (c compiled-file))
     8456    (perform (find-operation o 'load-op) c))
     8457  (defmethod perform ((o load-fasl-op) (c compiled-file))
     8458    (perform (find-operation o 'load-op) c))
     8459  (defmethod perform ((o operation) (c compiled-file))
     8460    (declare (ignorable o c))
     8461    nil))
     8462
     8463;;;
     8464;;; Pre-built systems
     8465;;;
     8466(with-upgradability ()
     8467  (defmethod trivial-system-p ((s prebuilt-system))
     8468    (declare (ignorable s))
     8469    t)
     8470
     8471  (defmethod perform ((o lib-op) (c prebuilt-system))
     8472    (declare (ignorable o c))
     8473    nil)
     8474
     8475  (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
     8476    (declare (ignorable o c))
     8477    nil)
     8478
     8479  (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
     8480    (declare (ignorable o))
     8481    nil))
     8482
     8483
     8484;;;
     8485;;; PREBUILT SYSTEM CREATOR
     8486;;;
     8487(with-upgradability ()
     8488  (defmethod output-files ((o binary-op) (s system))
     8489    (list (make-pathname :name (component-name s) :type "asd"
     8490                         :defaults (component-pathname s))))
     8491
     8492  (defmethod perform ((o binary-op) (s system))
     8493    (let* ((inputs (input-files o s))
     8494           (fasl (first inputs))
     8495           (library (second inputs))
     8496           (asd (first (output-files o s)))
     8497           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
     8498           (dependencies
     8499             (if (operation-monolithic-p o)
     8500                 (remove-if-not 'builtin-system-p
     8501                                (required-components s :component-type 'system
     8502                                                       :keep-operation 'load-op))
     8503                 (while-collecting (x) ;; resolve the sideway-dependencies of s
     8504                   (map-direct-dependencies
     8505                    'load-op s
     8506                    #'(lambda (o c)
     8507                        (when (and (typep o 'load-op) (typep c 'system))
     8508                          (x c)))))))
     8509           (depends-on (mapcar 'coerce-name dependencies)))
     8510      (when (pathname-equal asd (system-source-file s))
     8511        (cerror "overwrite the asd file"
     8512                "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
     8513                (cons o s) asd))
     8514      (with-open-file (s asd :direction :output :if-exists :supersede
     8515                             :if-does-not-exist :create)
     8516        (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
     8517                (operation-monolithic-p o) name)
     8518        (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
     8519                (lisp-implementation-type)
     8520                (lisp-implementation-version)
     8521                (software-type)
     8522                (machine-type)
     8523                (software-version))
     8524        (let ((*package* (find-package :asdf-user)))
     8525          (pprint `(defsystem ,name
     8526                     :class prebuilt-system
     8527                     :depends-on ,depends-on
     8528                     :components ((:compiled-file ,(pathname-name fasl)))
     8529                     ,@(when library `(:lib ,(file-namestring library))))
     8530                  s)
     8531          (terpri s)))))
     8532
     8533  #-(or ecl mkcl)
     8534  (defmethod perform ((o bundle-compile-op) (c system))
     8535    (let* ((input-files (input-files o c))
     8536           (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
     8537           (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
     8538           (output-files (output-files o c))
     8539           (output-file (first output-files)))
     8540      (assert (eq (not input-files) (not output-files)))
     8541      (when input-files
     8542        (when non-fasl-files
     8543          (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
     8544                 (implementation-type) non-fasl-files))
     8545        (when (and (typep o 'monolithic-bundle-op)
     8546                   (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
     8547          (error "prologue-code and epilogue-code are not supported on ~A"
     8548                 (implementation-type)))
     8549        (with-staging-pathname (output-file)
     8550          (combine-fasls fasl-files output-file)))))
     8551
     8552  (defmethod input-files ((o load-op) (s precompiled-system))
     8553    (declare (ignorable o))
     8554    (bundle-output-files (find-operation o 'fasl-op) s))
     8555
     8556  (defmethod perform ((o load-op) (s precompiled-system))
     8557    (perform-lisp-load-fasl o s))
     8558
     8559  (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
     8560    (declare (ignorable o))
     8561    `((load-op ,s) ,@(call-next-method))))
     8562
     8563  #| ;; Example use:
     8564(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
     8565(asdf:load-system :precompiled-asdf-utils)
     8566|#
     8567
     8568#+(or ecl mkcl)
     8569(with-upgradability ()
     8570  (defun uiop-library-file ()
     8571    (or (and (find-system :uiop nil)
     8572             (system-source-directory :uiop)
     8573             (progn
     8574               (operate 'lib-op :uiop)
     8575               (output-file 'lib-op :uiop)))
     8576        (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib))))
     8577  (defmethod input-files :around ((o program-op) (c system))
     8578    (let ((files (call-next-method))
     8579          (plan (traverse-sub-actions o c :plan-class 'sequential-plan)))
     8580      (unless (or (and (find-system :uiop nil)
     8581                       (system-source-directory :uiop)
     8582                       (plan-operates-on-p plan '("uiop")))
     8583                  (and (system-source-directory :asdf)
     8584                       (plan-operates-on-p plan '("asdf"))))
     8585        (pushnew (uiop-library-file) files :test 'pathname-equal))
     8586      files))
     8587
     8588  (defun register-pre-built-system (name)
     8589    (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
     8590
     8591#+ecl
     8592(with-upgradability ()
     8593  (defmethod perform ((o bundle-compile-op) (c system))
     8594    (let* ((object-files (input-files o c))
     8595           (output (output-files o c))
     8596           (bundle (first output))
     8597           (kind (bundle-type o)))
     8598      (when output
     8599        (create-image
     8600         bundle (append object-files (bundle-op-lisp-files o))
     8601         :kind kind
     8602         :entry-point (component-entry-point c)
     8603         :prologue-code
     8604         (when (typep o 'monolithic-bundle-op)
     8605           (monolithic-op-prologue-code o))
     8606         :epilogue-code
     8607         (when (typep o 'monolithic-bundle-op)
     8608           (monolithic-op-epilogue-code o))
     8609         :build-args (bundle-op-build-args o))))))
     8610
     8611#+mkcl
     8612(with-upgradability ()
     8613  (defmethod perform ((o lib-op) (s system))
     8614    (apply #'compiler::build-static-library (output-file o c)
     8615           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
     8616
     8617  (defmethod perform ((o basic-fasl-op) (s system))
     8618    (apply #'compiler::build-bundle (output-file o c) ;; second???
     8619           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
     8620
     8621  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
     8622    (declare (ignore force verbose version))
     8623    (apply #'operate 'binary-op system args)))
     8624;;;; -------------------------------------------------------------------------
     8625;;;; Concatenate-source
     8626
     8627(asdf/package:define-package :asdf/concatenate-source
     8628  (:recycle :asdf/concatenate-source :asdf)
     8629  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
     8630   :asdf/component :asdf/operation
     8631   :asdf/system :asdf/find-system :asdf/defsystem
     8632   :asdf/action :asdf/lisp-action :asdf/bundle)
     8633  (:export
     8634   #:concatenate-source-op
     8635   #:load-concatenated-source-op
     8636   #:compile-concatenated-source-op
     8637   #:load-compiled-concatenated-source-op
     8638   #:monolithic-concatenate-source-op
     8639   #:monolithic-load-concatenated-source-op
     8640   #:monolithic-compile-concatenated-source-op
     8641   #:monolithic-load-compiled-concatenated-source-op))
     8642(in-package :asdf/concatenate-source)
     8643
     8644;;;
     8645;;; Concatenate sources
     8646;;;
     8647(with-upgradability ()
     8648  (defclass basic-concatenate-source-op (bundle-op)
     8649    ((bundle-type :initform "lisp")))
     8650  (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
     8651  (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
     8652  (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
     8653
     8654  (defclass concatenate-source-op (basic-concatenate-source-op) ())
     8655  (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
     8656    ((selfward-operation :initform '(prepare-op concatenate-source-op))))
     8657  (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
     8658    ((selfward-operation :initform '(prepare-op concatenate-source-op))))
     8659  (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
     8660    ((selfward-operation :initform '(prepare-op compile-concatenated-source-op))))
     8661
     8662  (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ())
     8663  (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
     8664    ((selfward-operation :initform 'monolithic-concatenate-source-op)))
     8665  (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
     8666    ((selfward-operation :initform 'monolithic-concatenate-source-op)))
     8667  (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
     8668    ((selfward-operation :initform 'monolithic-compile-concatenated-source-op)))
     8669
     8670  (defmethod input-files ((operation basic-concatenate-source-op) (s system))
     8671    (loop :with encoding = (or (component-encoding s) *default-encoding*)
     8672          :with other-encodings = '()
     8673          :with around-compile = (around-compile-hook s)
     8674          :with other-around-compile = '()
     8675          :for c :in (required-components
     8676                      s :goal-operation 'compile-op
     8677                        :keep-operation 'compile-op
     8678                        :other-systems (operation-monolithic-p operation))
     8679          :append
     8680          (when (typep c 'cl-source-file)
     8681            (let ((e (component-encoding c)))
     8682              (unless (equal e encoding)
     8683                (pushnew e other-encodings :test 'equal)))
     8684            (let ((a (around-compile-hook c)))
     8685              (unless (equal a around-compile)
     8686                (pushnew a other-around-compile :test 'equal)))
     8687            (input-files (make-operation 'compile-op) c)) :into inputs
     8688          :finally
     8689             (when other-encodings
     8690               (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
     8691                     operation encoding other-encodings))
     8692             (when other-around-compile
     8693               (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
     8694                     operation around-compile other-around-compile))
     8695             (return inputs)))
     8696  (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
     8697    (lisp-compilation-output-files o s))
     8698
     8699  (defmethod perform ((o basic-concatenate-source-op) (s system))
     8700    (let ((inputs (input-files o s))
     8701          (output (output-file o s)))
     8702      (concatenate-files inputs output)))
     8703  (defmethod perform ((o basic-load-concatenated-source-op) (s system))
     8704    (perform-lisp-load-source o s))
     8705  (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
     8706    (perform-lisp-compilation o s))
     8707  (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
     8708    (perform-lisp-load-fasl o s)))
    75658709
    75668710;;;; ---------------------------------------------------------------------------
     
    76148758                                      (if (listp directory) (length directory) 0))))))))
    76158759    new-value)
    7616   (defsetf output-translations set-output-translations) ; works with gcl 2.6
     8760  #-gcl2.6
     8761  (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
     8762  #+gcl2.6
     8763  (defsetf output-translations set-output-translations)
    76178764
    76188765  (defun output-translations-initialized-p ()
     
    78799026        (normalize-device (apply-output-translations target))))))
    78809027
     9028;;;; -------------------------------------------------------------------------
     9029;;; Backward-compatible interfaces
     9030
     9031(asdf/package:define-package :asdf/backward-interface
     9032  (:recycle :asdf/backward-interface :asdf)
     9033  (:use :uiop/common-lisp :uiop :asdf/upgrade
     9034   :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
     9035   :asdf/lisp-action :asdf/operate :asdf/output-translations)
     9036  (:export
     9037   #:*asdf-verbose*
     9038   #:operation-error #:compile-error #:compile-failed #:compile-warned
     9039   #:error-component #:error-operation
     9040   #:component-load-dependencies
     9041   #:enable-asdf-binary-locations-compatibility
     9042   #:operation-forced
     9043   #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
     9044   #:component-property
     9045   #:run-shell-command
     9046   #:system-definition-pathname))
     9047(in-package :asdf/backward-interface)
     9048
     9049(with-upgradability ()
     9050  (define-condition operation-error (error) ;; Bad, backward-compatible name
     9051    ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
     9052    ((component :reader error-component :initarg :component)
     9053     (operation :reader error-operation :initarg :operation))
     9054    (:report (lambda (c s)
     9055               (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
     9056                       (type-of c) (error-operation c) (error-component c)))))
     9057  (define-condition compile-error (operation-error) ())
     9058  (define-condition compile-failed (compile-error) ())
     9059  (define-condition compile-warned (compile-error) ())
     9060
     9061  (defun component-load-dependencies (component)
     9062    ;; Old deprecated name for the same thing. Please update your software.
     9063    (component-sideway-dependencies component))
     9064
     9065  (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
     9066  (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
     9067
     9068  (defgeneric operation-on-warnings (operation))
     9069  (defgeneric operation-on-failure (operation))
     9070  #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
     9071  #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
     9072  (defmethod operation-on-warnings ((o operation))
     9073    (declare (ignorable o)) *compile-file-warnings-behaviour*)
     9074  (defmethod operation-on-failure ((o operation))
     9075    (declare (ignorable o)) *compile-file-failure-behaviour*)
     9076  (defmethod (setf operation-on-warnings) (x (o operation))
     9077    (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
     9078  (defmethod (setf operation-on-failure) (x (o operation))
     9079    (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
     9080
     9081  (defun system-definition-pathname (x)
     9082    ;; As of 2.014.8, we mean to make this function obsolete,
     9083    ;; but that won't happen until all clients have been updated.
     9084    ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
     9085    "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
     9086It used to expose ASDF internals with subtle differences with respect to
     9087user expectations, that have been refactored away since.
     9088We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
     9089for a mostly compatible replacement that we're supporting,
     9090or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
     9091if that's whay you mean." ;;)
     9092    (system-source-file x)))
     9093
     9094
     9095;;;; ASDF-Binary-Locations compatibility
     9096;; This remains supported for legacy user, but not recommended for new users.
     9097(with-upgradability ()
     9098  (defun enable-asdf-binary-locations-compatibility
     9099      (&key
     9100       (centralize-lisp-binaries nil)
     9101       (default-toplevel-directory
     9102        (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
     9103       (include-per-user-information nil)
     9104       (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
     9105       (source-to-target-mappings nil)
     9106       (file-types `(,(compile-file-type)
     9107                     "build-report"
     9108                     #+ecl (compile-file-type :type :object)
     9109                     #+mkcl (compile-file-type :fasl-p nil)
     9110                     #+clisp "lib" #+sbcl "cfasl"
     9111                     #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
     9112    #+(or clisp ecl mkcl)
     9113    (when (null map-all-source-files)
     9114      (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
     9115    (let* ((patterns (if map-all-source-files (list *wild-file*)
     9116                         (loop :for type :in file-types
     9117                               :collect (make-pathname :type type :defaults *wild-file*))))
     9118           (destination-directory
     9119             (if centralize-lisp-binaries
     9120                 `(,default-toplevel-directory
     9121                   ,@(when include-per-user-information
     9122                       (cdr (pathname-directory (user-homedir-pathname))))
     9123                   :implementation ,*wild-inferiors*)
     9124                 `(:root ,*wild-inferiors* :implementation))))
     9125      (initialize-output-translations
     9126       `(:output-translations
     9127         ,@source-to-target-mappings
     9128         #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
     9129         #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
     9130         ,@(loop :for pattern :in patterns
     9131                 :collect `((:root ,*wild-inferiors* ,pattern)
     9132                            (,@destination-directory ,pattern)))
     9133         (t t)
     9134         :ignore-inherited-configuration))))
     9135
     9136  (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
     9137    (declare (ignorable operation-class system args))
     9138    (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
     9139      (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
     9140ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
     9141which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
     9142and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
     9143In case you insist on preserving your previous A-B-L configuration, but
     9144do not know how to achieve the same effect with A-O-T, you may use function
     9145ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
     9146call that function where you would otherwise have loaded and configured A-B-L."))))
     9147
     9148
     9149;;; run-shell-command
     9150;; WARNING! The function below is not just deprecated but also dysfunctional.
     9151;; Please use asdf/run-program:run-program instead.
     9152(with-upgradability ()
     9153  (defun run-shell-command (control-string &rest args)
     9154    "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
     9155synchronously execute the result using a Bourne-compatible shell, with
     9156output to *VERBOSE-OUT*.  Returns the shell's exit code.
     9157
     9158PLEASE DO NOT USE.
     9159Deprecated function, for backward-compatibility only.
     9160Please use UIOP:RUN-PROGRAM instead."
     9161    (let ((command (apply 'format nil control-string args)))
     9162      (asdf-message "; $ ~A~%" command)
     9163      (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
     9164
     9165(with-upgradability ()
     9166  (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
     9167
     9168;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
     9169(with-upgradability ()
     9170  (defgeneric component-property (component property))
     9171  (defgeneric (setf component-property) (new-value component property))
     9172
     9173  (defmethod component-property ((c component) property)
     9174    (cdr (assoc property (slot-value c 'properties) :test #'equal)))
     9175
     9176  (defmethod (setf component-property) (new-value (c component) property)
     9177    (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
     9178      (if a
     9179          (setf (cdr a) new-value)
     9180          (setf (slot-value c 'properties)
     9181                (acons property new-value (slot-value c 'properties)))))
     9182    new-value))
    78819183;;;; -----------------------------------------------------------------
    78829184;;;; Source Registry Configuration, by Francois-Rene Rideau
     
    81949496
    81959497
    8196 ;;;; -------------------------------------------------------------------------
    8197 ;;; Internal hacks for backward-compatibility
    8198 
    8199 (asdf/package:define-package :asdf/backward-internals
    8200   (:recycle :asdf/backward-internals :asdf)
    8201   (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
    8202    :asdf/system :asdf/component :asdf/operation
    8203    :asdf/find-system :asdf/action :asdf/lisp-action)
    8204   (:export ;; for internal use
    8205    #:load-sysdef #:make-temporary-package
    8206    #:%refresh-component-inline-methods
    8207    #:%resolve-if-component-dep-fails
    8208    #:make-sub-operation
    8209    #:load-sysdef #:make-temporary-package))
    8210 (in-package :asdf/backward-internals)
    8211 
    8212 ;;;; Backward compatibility with "inline methods"
    8213 (with-upgradability ()
    8214   (defparameter +asdf-methods+
    8215     '(perform-with-restarts perform explain output-files operation-done-p))
    8216 
    8217   (defun %remove-component-inline-methods (component)
    8218     (dolist (name +asdf-methods+)
    8219       (map ()
    8220            ;; this is inefficient as most of the stored
    8221            ;; methods will not be for this particular gf
    8222            ;; But this is hardly performance-critical
    8223            #'(lambda (m)
    8224                (remove-method (symbol-function name) m))
    8225            (component-inline-methods component)))
    8226     (component-inline-methods component) nil)
    8227 
    8228   (defun %define-component-inline-methods (ret rest)
    8229     (dolist (name +asdf-methods+)
    8230       (let ((keyword (intern (symbol-name name) :keyword)))
    8231         (loop :for data = rest :then (cddr data)
    8232               :for key = (first data)
    8233               :for value = (second data)
    8234               :while data
    8235               :when (eq key keyword) :do
    8236                 (destructuring-bind (op qual? &rest rest) value
    8237                   (multiple-value-bind (qual args-and-body)
    8238                       (if (symbolp qual?)
    8239                           (values (list qual?) rest)
    8240                           (values nil (cons qual? rest)))
    8241                     (destructuring-bind ((o c) &body body) args-and-body
    8242                       (pushnew
    8243                        (eval `(defmethod ,name ,@qual ((,o ,op) (,c (eql ,ret)))
    8244                                 ,@body))
    8245                        (component-inline-methods ret)))))))))
    8246 
    8247   (defun %refresh-component-inline-methods (component rest)
    8248     ;; clear methods, then add the new ones
    8249     (%remove-component-inline-methods component)
    8250     (%define-component-inline-methods component rest)))
    8251 
    8252 ;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
    8253 ;; and the companion asdf:feature pseudo-dependency.
    8254 ;; This won't recurse into dependencies to accumulate feature conditions.
    8255 ;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
    8256 ;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
    8257 (with-upgradability ()
    8258   (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
    8259     (asdf-message "The system definition for ~S uses deprecated ~
    8260                  ASDF option :IF-COMPONENT-DEP-DAILS. ~
    8261                  Starting with ASDF 3, please use :IF-FEATURE instead"
    8262                   (coerce-name (component-system component)))
    8263     ;; This only supports the pattern of use of the "feature" seen in the wild
    8264     (check-type component parent-component)
    8265     (check-type if-component-dep-fails (member :fail :ignore :try-next))
    8266     (unless (eq if-component-dep-fails :fail)
    8267       (loop :with o = (make-operation 'compile-op)
    8268             :for c :in (component-children component) :do
    8269               (loop* :for (feature? feature) :in (component-depends-on o c)
    8270                      :when (eq feature? 'feature) :do
    8271                      (setf (component-if-feature c) feature))))))
    8272 
    8273 (when-upgrading (:when (fboundp 'make-sub-operation))
    8274   (defun make-sub-operation (c o dep-c dep-o)
    8275     (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
    8276 
    8277 
    8278 ;;;; load-sysdef
    8279 (with-upgradability ()
    8280   (defun load-sysdef (name pathname)
    8281     (load-asd pathname :name name))
    8282 
    8283   (defun make-temporary-package ()
    8284     ;; For loading a .asd file, we dont't make a temporary package anymore,
    8285     ;; but use ASDF-USER. I'd like to have this function do this,
    8286     ;; but since whoever uses it is likely to delete-package the result afterwards,
    8287     ;; this would be a bad idea, so preserve the old behavior.
    8288     (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
    8289 
    8290 
    8291 ;;;; -------------------------------------------------------------------------
    8292 ;;;; Defsystem
    8293 
    8294 (asdf/package:define-package :asdf/defsystem
    8295   (:recycle :asdf/defsystem :asdf)
    8296   (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
    8297    :asdf/component :asdf/system :asdf/cache
    8298    :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
    8299    :asdf/backward-internals)
    8300   (:export
    8301    #:defsystem #:register-system-definition
    8302    #:class-for-type #:*default-component-class*
    8303    #:determine-system-directory #:parse-component-form
    8304    #:duplicate-names #:sysdef-error-component #:check-component-input))
    8305 (in-package :asdf/defsystem)
    8306 
    8307 ;;; Pathname
    8308 (with-upgradability ()
    8309   (defun determine-system-directory (pathname)
    8310     ;; The defsystem macro calls this function to determine
    8311     ;; the pathname of a system as follows:
    8312     ;; 1. if the pathname argument is an pathname object (NOT a namestring),
    8313     ;;    that is already an absolute pathname, return it.
    8314     ;; 2. otherwise, the directory containing the LOAD-PATHNAME
    8315     ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
    8316     ;;    if it is indeed available and an absolute pathname, then
    8317     ;;    the PATHNAME argument is normalized to a relative pathname
    8318     ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
    8319     ;;    and merged into that DIRECTORY as per SUBPATHNAME.
    8320     ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
    8321     ;;    and may be from within the EVAL-WHEN of a file compilation.
    8322     ;; If no absolute pathname was found, we return NIL.
    8323     (check-type pathname (or null string pathname))
    8324     (pathname-directory-pathname
    8325      (resolve-symlinks*
    8326       (ensure-absolute-pathname
    8327        (parse-unix-namestring pathname :type :directory)
    8328        #'(lambda () (ensure-absolute-pathname
    8329                      (load-pathname) 'get-pathname-defaults nil))
    8330        nil)))))
    8331 
    8332 
    8333 ;;; Component class
    8334 (with-upgradability ()
    8335   (defvar *default-component-class* 'cl-source-file)
    8336 
    8337   (defun class-for-type (parent type)
    8338     (or (loop :for symbol :in (list
    8339                                type
    8340                                (find-symbol* type *package* nil)
    8341                                (find-symbol* type :asdf/interface nil)
    8342                                (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
    8343               :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
    8344               :when (and class
    8345                          (#-cormanlisp subtypep #+cormanlisp cl::subclassp
    8346                           class (find-class* 'component)))
    8347                 :return class)
    8348         (and (eq type :file)
    8349              (find-class*
    8350               (or (loop :for p = parent :then (component-parent p) :while p
    8351                         :thereis (module-default-component-class p))
    8352                   *default-component-class*) nil))
    8353         (sysdef-error "don't recognize component type ~A" type))))
    8354 
    8355 
    8356 ;;; Check inputs
    8357 (with-upgradability ()
    8358   (define-condition duplicate-names (system-definition-error)
    8359     ((name :initarg :name :reader duplicate-names-name))
    8360     (:report (lambda (c s)
    8361                (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
    8362                        (duplicate-names-name c)))))
    8363 
    8364   (defun sysdef-error-component (msg type name value)
    8365     (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
    8366                   type name value))
    8367 
    8368   (defun check-component-input (type name weakly-depends-on
    8369                                 depends-on components)
    8370     "A partial test of the values of a component."
    8371     (unless (listp depends-on)
    8372       (sysdef-error-component ":depends-on must be a list."
    8373                               type name depends-on))
    8374     (unless (listp weakly-depends-on)
    8375       (sysdef-error-component ":weakly-depends-on must be a list."
    8376                               type name weakly-depends-on))
    8377     (unless (listp components)
    8378       (sysdef-error-component ":components must be NIL or a list of components."
    8379                               type name components)))
    8380 
    8381   (defun* (normalize-version) (form &key pathname component parent)
    8382     (labels ((invalid (&optional (continuation "using NIL instead"))
    8383                (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
    8384                      form component parent pathname continuation))
    8385              (invalid-parse (control &rest args)
    8386                (unless (builtin-system-p (find-component parent component))
    8387                  (apply 'warn control args)
    8388                  (invalid))))
    8389       (if-let (v (typecase form
    8390                    ((or string null) form)
    8391                    (real
    8392                     (invalid "Substituting a string")
    8393                     (format nil "~D" form)) ;; 1.0 becomes "1.0"
    8394                    (cons
    8395                     (case (first form)
    8396                       ((:read-file-form)
    8397                        (destructuring-bind (subpath &key (at 0)) (rest form)
    8398                          (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
    8399                       ((:read-file-line)
    8400                        (destructuring-bind (subpath &key (at 0)) (rest form)
    8401                          (read-file-lines (subpathname pathname subpath) :at at)))
    8402                       (otherwise
    8403                        (invalid))))
    8404                    (t
    8405                     (invalid))))
    8406         (if-let (pv (parse-version v #'invalid-parse))
    8407           (unparse-version pv)
    8408           (invalid))))))
    8409 
    8410 
    8411 ;;; Main parsing function
    8412 (with-upgradability ()
    8413   (defun* (parse-component-form) (parent options &key previous-serial-component)
    8414     (destructuring-bind
    8415         (type name &rest rest &key
    8416                                 (builtin-system-p () bspp)
    8417                                 ;; the following list of keywords is reproduced below in the
    8418                                 ;; remove-plist-keys form.  important to keep them in sync
    8419                                 components pathname perform explain output-files operation-done-p
    8420                                 weakly-depends-on depends-on serial
    8421                                 do-first if-component-dep-fails version
    8422                                 ;; list ends
    8423          &allow-other-keys) options
    8424       (declare (ignorable perform explain output-files operation-done-p builtin-system-p))
    8425       (check-component-input type name weakly-depends-on depends-on components)
    8426       (when (and parent
    8427                  (find-component parent name)
    8428                  (not ;; ignore the same object when rereading the defsystem
    8429                   (typep (find-component parent name)
    8430                          (class-for-type parent type))))
    8431         (error 'duplicate-names :name name))
    8432       (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
    8433       (let* ((args `(:name ,(coerce-name name)
    8434                      :pathname ,pathname
    8435                      ,@(when parent `(:parent ,parent))
    8436                      ,@(remove-plist-keys
    8437                         '(:components :pathname :if-component-dep-fails :version
    8438                           :perform :explain :output-files :operation-done-p
    8439                           :weakly-depends-on :depends-on :serial)
    8440                         rest)))
    8441              (component (find-component parent name)))
    8442         (when weakly-depends-on
    8443           ;; ASDF4: deprecate this feature and remove it.
    8444           (appendf depends-on
    8445                    (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
    8446         (when previous-serial-component
    8447           (push previous-serial-component depends-on))
    8448         (if component ; preserve identity
    8449             (apply 'reinitialize-instance component args)
    8450             (setf component (apply 'make-instance (class-for-type parent type) args)))
    8451         (component-pathname component) ; eagerly compute the absolute pathname
    8452         (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
    8453           (when (and (typep component 'system) (not bspp))
    8454             (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
    8455           (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
    8456         ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
    8457         ;; A better fix is required.
    8458         (setf (slot-value component 'version) version)
    8459         (when (typep component 'parent-component)
    8460           (setf (component-children component)
    8461                 (loop
    8462                   :with previous-component = nil
    8463                   :for c-form :in components
    8464                   :for c = (parse-component-form component c-form
    8465                                                  :previous-serial-component previous-component)
    8466                   :for name = (component-name c)
    8467                   :collect c
    8468                   :when serial :do (setf previous-component name)))
    8469           (compute-children-by-name component))
    8470         ;; Used by POIU. ASDF4: rename to component-depends-on?
    8471         (setf (component-sibling-dependencies component) depends-on)
    8472         (%refresh-component-inline-methods component rest)
    8473         (when if-component-dep-fails
    8474           (%resolve-if-component-dep-fails if-component-dep-fails component))
    8475         component)))
    8476 
    8477   (defun register-system-definition
    8478       (name &rest options &key pathname (class 'system) (source-file () sfp)
    8479                             defsystem-depends-on &allow-other-keys)
    8480     ;; The system must be registered before we parse the body,
    8481     ;; otherwise we recur when trying to find an existing system
    8482     ;; of the same name to reuse options (e.g. pathname) from.
    8483     ;; To avoid infinite recursion in cases where you defsystem a system
    8484     ;; that is registered to a different location to find-system,
    8485     ;; we also need to remember it in a special variable *systems-being-defined*.
    8486     (with-system-definitions ()
    8487       (let* ((name (coerce-name name))
    8488              (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
    8489              (registered (system-registered-p name))
    8490              (registered! (if registered
    8491                               (rplaca registered (get-file-stamp source-file))
    8492                               (register-system
    8493                                (make-instance 'system :name name :source-file source-file))))
    8494              (system (reset-system (cdr registered!)
    8495                                    :name name :source-file source-file))
    8496              (component-options (remove-plist-key :class options))
    8497              (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
    8498                                            (resolve-dependency-spec nil spec))))
    8499         (setf (gethash name *systems-being-defined*) system)
    8500         (apply 'load-systems defsystem-dependencies)
    8501         ;; We change-class AFTER we loaded the defsystem-depends-on
    8502         ;; since the class might be defined as part of those.
    8503         (let ((class (class-for-type nil class)))
    8504           (unless (eq (type-of system) class)
    8505             (change-class system class)))
    8506         (parse-component-form
    8507          nil (list*
    8508               :module name
    8509               :pathname (determine-system-directory pathname)
    8510               component-options)))))
    8511 
    8512   (defmacro defsystem (name &body options)
    8513     `(apply 'register-system-definition ',name ',options)))
    8514 ;;;; -------------------------------------------------------------------------
    8515 ;;;; ASDF-Bundle
    8516 
    8517 (asdf/package:define-package :asdf/bundle
    8518   (:recycle :asdf/bundle :asdf)
    8519   (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
    8520    :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
    8521    :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
    8522   (:export
    8523    #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
    8524    #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
    8525    #:monolithic-op #:monolithic-bundle-op #:bundlable-file-p #:direct-dependency-files
    8526    #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
    8527    #:program-op
    8528    #:compiled-file #:precompiled-system #:prebuilt-system
    8529    #:operation-monolithic-p
    8530    #:user-system-p #:user-system #:trivial-system-p
    8531    #+ecl #:make-build
    8532    #:register-pre-built-system
    8533    #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
    8534 (in-package :asdf/bundle)
    8535 
    8536 (with-upgradability ()
    8537   (defclass bundle-op (operation)
    8538     ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
    8539      (name-suffix :initarg :name-suffix :initform nil)
    8540      (bundle-type :initform :no-output-file :reader bundle-type)
    8541      #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
    8542      #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
    8543      #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
    8544 
    8545   (defclass fasl-op (bundle-op)
    8546     ;; create a single fasl for the entire library
    8547     ((bundle-type :initform :fasl)))
    8548 
    8549   (defclass load-fasl-op (basic-load-op)
    8550     ;; load a single fasl for the entire library
    8551     ())
    8552 
    8553   (defclass lib-op (bundle-op)
    8554     ;; On ECL: compile the system and produce linkable .a library for it.
    8555     ;; On others: just compile the system.
    8556     ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)))
    8557 
    8558   (defclass dll-op (bundle-op)
    8559     ;; Link together all the dynamic library used by this system into a single one.
    8560     ((bundle-type :initform :dll)))
    8561 
    8562   (defclass binary-op (bundle-op)
    8563     ;; On ECL: produce lib and fasl for the system.
    8564     ;; On "normal" Lisps: produce just the fasl.
    8565     ())
    8566 
    8567   (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
    8568 
    8569   (defclass monolithic-bundle-op (monolithic-op bundle-op)
    8570     ((prologue-code :accessor monolithic-op-prologue-code)
    8571      (epilogue-code :accessor monolithic-op-epilogue-code)))
    8572 
    8573   (defclass monolithic-binary-op (binary-op monolithic-bundle-op)
    8574     ;; On ECL: produce lib and fasl for combined system and dependencies.
    8575     ;; On "normal" Lisps: produce an image file from system and dependencies.
    8576     ())
    8577 
    8578   (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
    8579     ;; Create a single fasl for the system and its dependencies.
    8580     ())
    8581 
    8582   (defclass monolithic-lib-op (monolithic-bundle-op lib-op)
    8583     ;; ECL: Create a single linkable library for the system and its dependencies.
    8584     ((bundle-type :initform :lib)))
    8585 
    8586   (defclass monolithic-dll-op (monolithic-bundle-op dll-op)
    8587     ((bundle-type :initform :dll)))
    8588 
    8589   (defclass program-op (monolithic-bundle-op)
    8590     ;; All: create an executable file from the system and its dependencies
    8591     ((bundle-type :initform :program)))
    8592 
    8593   (defun bundle-pathname-type (bundle-type)
    8594     (etypecase bundle-type
    8595       ((eql :no-output-file) nil) ;; should we error out instead?   
    8596       ((or null string) bundle-type)
    8597       ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
    8598       #+ecl
    8599       ((member :binary :dll :lib :static-library :program :object :program)
    8600        (compile-file-type :type bundle-type))
    8601       ((eql :binary) "image")
    8602       ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
    8603       ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
    8604       ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
    8605 
    8606   (defun bundle-output-files (o c)
    8607     (let ((bundle-type (bundle-type o)))
    8608       (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
    8609         (let ((name (or (component-build-pathname c)
    8610                         (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
    8611               (type (bundle-pathname-type bundle-type)))
    8612           (values (list (subpathname (component-pathname c) name :type type))
    8613                   (eq (type-of o) (component-build-operation c)))))))
    8614 
    8615   (defmethod output-files ((o bundle-op) (c system))
    8616     (bundle-output-files o c))
    8617 
    8618   #-(or ecl mkcl)
    8619   (progn
    8620     (defmethod perform ((o program-op) (c system))
    8621       (let ((output-file (output-file o c)))
    8622         (setf *image-entry-point* (ensure-function (component-entry-point c)))
    8623         (dump-image output-file :executable t)))
    8624 
    8625     (defmethod perform ((o monolithic-binary-op) (c system))
    8626       (let ((output-file (output-file o c)))
    8627         (dump-image output-file))))
    8628 
    8629   (defclass compiled-file (file-component)
    8630     ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
    8631 
    8632   (defclass precompiled-system (system)
    8633     ((build-pathname :initarg :fasl)))
    8634 
    8635   (defclass prebuilt-system (system)
    8636     ((build-pathname :initarg :static-library :initarg :lib
    8637                      :accessor prebuilt-system-static-library))))
    8638 
    8639 
    8640 ;;;
    8641 ;;; BUNDLE-OP
    8642 ;;;
    8643 ;;; This operation takes all components from one or more systems and
    8644 ;;; creates a single output file, which may be
    8645 ;;; a FASL, a statically linked library, a shared library, etc.
    8646 ;;; The different targets are defined by specialization.
    8647 ;;;
    8648 (with-upgradability ()
    8649   (defun operation-monolithic-p (op)
    8650     (typep op 'monolithic-op))
    8651 
    8652   (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
    8653                                          &key (name-suffix nil name-suffix-p)
    8654                                          &allow-other-keys)
    8655     (declare (ignorable initargs name-suffix))
    8656     (unless name-suffix-p
    8657       (setf (slot-value instance 'name-suffix)
    8658             (unless (typep instance 'program-op)
    8659               (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
    8660     (when (typep instance 'monolithic-bundle-op)
    8661       (destructuring-bind (&rest original-initargs
    8662                            &key lisp-files prologue-code epilogue-code
    8663                            &allow-other-keys)
    8664           (operation-original-initargs instance)
    8665         (setf (operation-original-initargs instance)
    8666               (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
    8667               (monolithic-op-prologue-code instance) prologue-code
    8668               (monolithic-op-epilogue-code instance) epilogue-code)
    8669         #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
    8670         #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
    8671     (setf (bundle-op-build-args instance)
    8672           (remove-plist-keys '(:type :monolithic :name-suffix)
    8673                              (operation-original-initargs instance))))
    8674 
    8675   (defmethod bundle-op-build-args :around ((o lib-op))
    8676     (declare (ignorable o))
    8677     (let ((args (call-next-method)))
    8678       (remf args :ld-flags)
    8679       args))
    8680 
    8681   (defun bundlable-file-p (pathname)
    8682     (let ((type (pathname-type pathname)))
    8683       (declare (ignorable type))
    8684       (or #+ecl (or (equalp type (compile-file-type :type :object))
    8685                     (equalp type (compile-file-type :type :static-library)))
    8686           #+mkcl (equalp type (compile-file-type :fasl-p nil))
    8687           #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
    8688 
    8689   (defgeneric* (trivial-system-p) (component))
    8690 
    8691   (defun user-system-p (s)
    8692     (and (typep s 'system)
    8693          (not (builtin-system-p s))
    8694          (not (trivial-system-p s)))))
    8695 
    8696 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
    8697   (deftype user-system () '(and system (satisfies user-system-p))))
    8698 
    8699 ;;;
    8700 ;;; First we handle monolithic bundles.
    8701 ;;; These are standalone systems which contain everything,
    8702 ;;; including other ASDF systems required by the current one.
    8703 ;;; A PROGRAM is always monolithic.
    8704 ;;;
    8705 ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
    8706 ;;;
    8707 (with-upgradability ()
    8708   (defmethod component-depends-on ((o monolithic-lib-op) (c system))
    8709     (declare (ignorable o))
    8710     `((lib-op ,@(required-components c :other-systems t :component-type 'system
    8711                                        :goal-operation 'load-op
    8712                                        :keep-operation 'compile-op))))
    8713 
    8714   (defmethod component-depends-on ((o monolithic-fasl-op) (c system))
    8715     (declare (ignorable o))
    8716     `((fasl-op ,@(required-components c :other-systems t :component-type 'system
    8717                                         :goal-operation 'load-fasl-op
    8718                                         :keep-operation 'fasl-op))))
    8719 
    8720   (defmethod component-depends-on ((o program-op) (c system))
    8721     (declare (ignorable o))
    8722     #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c)
    8723     #-(or ecl mkcl) `((load-op ,c)))
    8724 
    8725   (defmethod component-depends-on ((o binary-op) (c system))
    8726     (declare (ignorable o))
    8727     `((fasl-op ,c)
    8728       (lib-op ,c)))
    8729 
    8730   (defmethod component-depends-on ((o monolithic-binary-op) (c system))
    8731     `((,(find-operation o 'monolithic-fasl-op) ,c)
    8732       (,(find-operation o 'monolithic-lib-op) ,c)))
    8733 
    8734   (defmethod component-depends-on ((o lib-op) (c system))
    8735     (declare (ignorable o))
    8736     `((compile-op ,@(required-components c :other-systems nil :component-type '(not system)
    8737                                            :goal-operation 'load-op
    8738                                            :keep-operation 'compile-op))))
    8739 
    8740   (defmethod component-depends-on ((o fasl-op) (c system))
    8741     (declare (ignorable o))
    8742     #+ecl `((lib-op ,c))
    8743     #-ecl
    8744     (component-depends-on (find-operation o 'lib-op) c))
    8745 
    8746   (defmethod component-depends-on ((o dll-op) c)
    8747     (component-depends-on (find-operation o 'lib-op) c))
    8748 
    8749   (defmethod component-depends-on ((o bundle-op) c)
    8750     (declare (ignorable o c))
    8751     nil)
    8752 
    8753   (defmethod component-depends-on :around ((o bundle-op) (c component))
    8754     (declare (ignorable o c))
    8755     (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
    8756       `((,op ,c))
    8757       (call-next-method)))
    8758 
    8759   (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
    8760     (while-collecting (collect)
    8761       (map-direct-dependencies
    8762        o c #'(lambda (sub-o sub-c)
    8763                (loop :for f :in (funcall key sub-o sub-c)
    8764                      :when (funcall test f) :do (collect f))))))
    8765 
    8766   (defmethod input-files ((o bundle-op) (c system))
    8767     (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))
    8768 
    8769   (defun select-bundle-operation (type &optional monolithic)
    8770     (ecase type
    8771       ((:binary)
    8772        (if monolithic 'monolithic-binary-op 'binary-op))
    8773       ((:dll :shared-library)
    8774        (if monolithic 'monolithic-dll-op 'dll-op))
    8775       ((:lib :static-library)
    8776        (if monolithic 'monolithic-lib-op 'lib-op))
    8777       ((:fasl)
    8778        (if monolithic 'monolithic-fasl-op 'fasl-op))
    8779       ((:program)
    8780        'program-op)))
    8781 
    8782   (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
    8783                              (move-here nil move-here-p)
    8784                              &allow-other-keys)
    8785     (let* ((operation-name (select-bundle-operation type monolithic))
    8786            (move-here-path (if (and move-here
    8787                                     (typep move-here '(or pathname string)))
    8788                                (pathname move-here)
    8789                                (system-relative-pathname system "asdf-output/")))
    8790            (operation (apply #'operate operation-name
    8791                              system
    8792                              (remove-plist-keys '(:monolithic :type :move-here) args)))
    8793            (system (find-system system))
    8794            (files (and system (output-files operation system))))
    8795       (if (or move-here (and (null move-here-p)
    8796                              (member operation-name '(:program :binary))))
    8797           (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
    8798                 :for f :in files
    8799                 :for new-f = (make-pathname :name (pathname-name f)
    8800                                             :type (pathname-type f)
    8801                                             :defaults dest-path)
    8802                 :do (rename-file-overwriting-target f new-f)
    8803                 :collect new-f)
    8804           files))))
    8805 
    8806 ;;;
    8807 ;;; LOAD-FASL-OP
    8808 ;;;
    8809 ;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
    8810 ;;;
    8811 (with-upgradability ()
    8812   (defmethod component-depends-on ((o load-fasl-op) (c system))
    8813     (declare (ignorable o))
    8814     `((,o ,@(loop :for dep :in (component-sibling-dependencies c)
    8815                   :collect (resolve-dependency-spec c dep)))
    8816       (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
    8817       ,@(call-next-method)))
    8818 
    8819   (defmethod input-files ((o load-fasl-op) (c system))
    8820     (when (user-system-p c)
    8821       (output-files (find-operation o 'fasl-op) c)))
    8822 
    8823   (defmethod perform ((o load-fasl-op) c)
    8824     (declare (ignorable o c))
    8825     nil)
    8826 
    8827   (defmethod perform ((o load-fasl-op) (c system))
    8828     (perform-lisp-load-fasl o c))
    8829 
    8830   (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
    8831     (mark-operation-done (find-operation o 'load-op) c)))
    8832 
    8833 ;;;
    8834 ;;; PRECOMPILED FILES
    8835 ;;;
    8836 ;;; This component can be used to distribute ASDF systems in precompiled form.
    8837 ;;; Only useful when the dependencies have also been precompiled.
    8838 ;;;
    8839 (with-upgradability ()
    8840   (defmethod trivial-system-p ((s system))
    8841     (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
    8842 
    8843   (defmethod output-files (o (c compiled-file))
    8844     (declare (ignorable o c))
    8845     nil)
    8846   (defmethod input-files (o (c compiled-file))
    8847     (declare (ignorable o))
    8848     (component-pathname c))
    8849   (defmethod perform ((o load-op) (c compiled-file))
    8850     (perform-lisp-load-fasl o c))
    8851   (defmethod perform ((o load-source-op) (c compiled-file))
    8852     (perform (find-operation o 'load-op) c))
    8853   (defmethod perform ((o load-fasl-op) (c compiled-file))
    8854     (perform (find-operation o 'load-op) c))
    8855   (defmethod perform ((o operation) (c compiled-file))
    8856     (declare (ignorable o c))
    8857     nil))
    8858 
    8859 ;;;
    8860 ;;; Pre-built systems
    8861 ;;;
    8862 (with-upgradability ()
    8863   (defmethod trivial-system-p ((s prebuilt-system))
    8864     (declare (ignorable s))
    8865     t)
    8866 
    8867   (defmethod perform ((o lib-op) (c prebuilt-system))
    8868     (declare (ignorable o c))
    8869     nil)
    8870 
    8871   (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
    8872     (declare (ignorable o c))
    8873     nil)
    8874 
    8875   (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
    8876     (declare (ignorable o))
    8877     nil))
    8878 
    8879 
    8880 ;;;
    8881 ;;; PREBUILT SYSTEM CREATOR
    8882 ;;;
    8883 (with-upgradability ()
    8884   (defmethod output-files ((o binary-op) (s system))
    8885     (list (make-pathname :name (component-name s) :type "asd"
    8886                          :defaults (component-pathname s))))
    8887 
    8888   (defmethod perform ((o binary-op) (s system))
    8889     (let* ((dependencies (component-depends-on o s))
    8890            (fasl (first (apply #'output-files (first dependencies))))
    8891            (library (first (apply #'output-files (second dependencies))))
    8892            (asd (first (output-files o s)))
    8893            (name (pathname-name asd))
    8894            (name-keyword (intern (string name) (find-package :keyword))))
    8895       (with-open-file (s asd :direction :output :if-exists :supersede
    8896                              :if-does-not-exist :create)
    8897         (format s ";;; Prebuilt ASDF definition for system ~A" name)
    8898         (format s ";;; Built for ~A ~A on a ~A/~A ~A"
    8899                 (lisp-implementation-type)
    8900                 (lisp-implementation-version)
    8901                 (software-type)
    8902                 (machine-type)
    8903                 (software-version))
    8904         (let ((*package* (find-package :keyword)))
    8905           (pprint `(defsystem ,name-keyword
    8906                      :class prebuilt-system
    8907                      :components ((:compiled-file ,(pathname-name fasl)))
    8908                      :lib ,(and library (file-namestring library)))
    8909                   s)))))
    8910 
    8911   #-(or ecl mkcl)
    8912   (defmethod perform ((o fasl-op) (c system))
    8913     (let* ((input-files (input-files o c))
    8914            (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
    8915            (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
    8916            (output-files (output-files o c))
    8917            (output-file (first output-files)))
    8918       (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
    8919       (when input-files
    8920         (assert output-files)
    8921         (when non-fasl-files
    8922           (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
    8923                  (implementation-type) non-fasl-files))
    8924         (when (and (typep o 'monolithic-bundle-op)
    8925                    (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
    8926           (error "prologue-code and epilogue-code are not supported on ~A"
    8927                  (implementation-type)))
    8928         (with-staging-pathname (output-file)
    8929           (combine-fasls fasl-files output-file)))))
    8930 
    8931   (defmethod input-files ((o load-op) (s precompiled-system))
    8932     (declare (ignorable o))
    8933     (bundle-output-files (find-operation o 'fasl-op) s))
    8934 
    8935   (defmethod perform ((o load-op) (s precompiled-system))
    8936     (perform-lisp-load-fasl o s))
    8937 
    8938   (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
    8939     (declare (ignorable o))
    8940     `((load-op ,s) ,@(call-next-method))))
    8941 
    8942   #| ;; Example use:
    8943 (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
    8944 (asdf:load-system :precompiled-asdf-utils)
    8945 |#
    8946 
    8947 #+ecl
    8948 (with-upgradability ()
    8949   (defmethod perform ((o bundle-op) (c system))
    8950     (let* ((object-files (input-files o c))
    8951            (output (output-files o c))
    8952            (bundle (first output))
    8953            (kind (bundle-type o)))
    8954       (create-image
    8955        bundle (append object-files (bundle-op-lisp-files o))
    8956        :kind kind
    8957        :entry-point (component-entry-point c)
    8958        :prologue-code
    8959        (when (typep o 'monolithic-bundle-op)
    8960          (monolithic-op-prologue-code o))
    8961        :epilogue-code
    8962        (when (typep o 'monolithic-bundle-op)
    8963          (monolithic-op-epilogue-code o))
    8964        :build-args (bundle-op-build-args o)))))
    8965 
    8966 #+mkcl
    8967 (with-upgradability ()
    8968   (defmethod perform ((o lib-op) (s system))
    8969     (apply #'compiler::build-static-library (first output)
    8970            :lisp-object-files (input-files o s) (bundle-op-build-args o)))
    8971 
    8972   (defmethod perform ((o fasl-op) (s system))
    8973     (apply #'compiler::build-bundle (second output)
    8974            :lisp-object-files (input-files o s) (bundle-op-build-args o)))
    8975 
    8976   (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
    8977     (declare (ignore force verbose version))
    8978     (apply #'operate 'binary-op system args)))
    8979 
    8980 #+(or ecl mkcl)
    8981 (with-upgradability ()
    8982   (defun register-pre-built-system (name)
    8983     (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
    8984 
    8985 ;;;; -------------------------------------------------------------------------
    8986 ;;;; Concatenate-source
    8987 
    8988 (asdf/package:define-package :asdf/concatenate-source
    8989   (:recycle :asdf/concatenate-source :asdf)
    8990   (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
    8991    :asdf/component :asdf/operation
    8992    :asdf/system :asdf/find-system :asdf/defsystem
    8993    :asdf/action :asdf/lisp-action :asdf/bundle)
    8994   (:export
    8995    #:concatenate-source-op
    8996    #:load-concatenated-source-op
    8997    #:compile-concatenated-source-op
    8998    #:load-compiled-concatenated-source-op
    8999    #:monolithic-concatenate-source-op
    9000    #:monolithic-load-concatenated-source-op
    9001    #:monolithic-compile-concatenated-source-op
    9002    #:monolithic-load-compiled-concatenated-source-op))
    9003 (in-package :asdf/concatenate-source)
    9004 
    9005 ;;;
    9006 ;;; Concatenate sources
    9007 ;;;
    9008 (with-upgradability ()
    9009   (defclass concatenate-source-op (bundle-op)
    9010     ((bundle-type :initform "lisp")))
    9011   (defclass load-concatenated-source-op (basic-load-op operation)
    9012     ((bundle-type :initform :no-output-file)))
    9013   (defclass compile-concatenated-source-op (basic-compile-op bundle-op)
    9014     ((bundle-type :initform :fasl)))
    9015   (defclass load-compiled-concatenated-source-op (basic-load-op operation)
    9016     ((bundle-type :initform :no-output-file)))
    9017 
    9018   (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
    9019   (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
    9020   (defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
    9021   (defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
    9022 
    9023   (defmethod input-files ((operation concatenate-source-op) (s system))
    9024     (loop :with encoding = (or (component-encoding s) *default-encoding*)
    9025           :with other-encodings = '()
    9026           :with around-compile = (around-compile-hook s)
    9027           :with other-around-compile = '()
    9028           :for c :in (required-components
    9029                       s :goal-operation 'compile-op
    9030                         :keep-operation 'compile-op
    9031                         :other-systems (operation-monolithic-p operation))
    9032           :append
    9033           (when (typep c 'cl-source-file)
    9034             (let ((e (component-encoding c)))
    9035               (unless (equal e encoding)
    9036                 (pushnew e other-encodings :test 'equal)))
    9037             (let ((a (around-compile-hook c)))
    9038               (unless (equal a around-compile)
    9039                 (pushnew a other-around-compile :test 'equal)))
    9040             (input-files (make-operation 'compile-op) c)) :into inputs
    9041           :finally
    9042              (when other-encodings
    9043                (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
    9044                      operation encoding other-encodings))
    9045              (when other-around-compile
    9046                (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
    9047                      operation around-compile other-around-compile))
    9048              (return inputs)))
    9049 
    9050   (defmethod input-files ((o load-concatenated-source-op) (s system))
    9051     (direct-dependency-files o s))
    9052   (defmethod input-files ((o compile-concatenated-source-op) (s system))
    9053     (direct-dependency-files o s))
    9054   (defmethod output-files ((o compile-concatenated-source-op) (s system))
    9055     (let ((input (first (input-files o s))))
    9056       (list (compile-file-pathname input))))
    9057   (defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
    9058     (direct-dependency-files o s))
    9059 
    9060   (defmethod perform ((o concatenate-source-op) (s system))
    9061     (let ((inputs (input-files o s))
    9062           (output (output-file o s)))
    9063       (concatenate-files inputs output)))
    9064   (defmethod perform ((o load-concatenated-source-op) (s system))
    9065     (perform-lisp-load-source o s))
    9066   (defmethod perform ((o compile-concatenated-source-op) (s system))
    9067     (perform-lisp-compilation o s))
    9068   (defmethod perform ((o load-compiled-concatenated-source-op) (s system))
    9069     (perform-lisp-load-fasl o s))
    9070 
    9071   (defmethod component-depends-on ((o concatenate-source-op) (s system))
    9072     (declare (ignorable o s)) nil)
    9073   (defmethod component-depends-on ((o load-concatenated-source-op) (s system))
    9074     (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s)))
    9075   (defmethod component-depends-on ((o compile-concatenated-source-op) (s system))
    9076     (declare (ignorable o s)) `((concatenate-source-op ,s)))
    9077   (defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system))
    9078     (declare (ignorable o s)) `((compile-concatenated-source-op ,s)))
    9079 
    9080   (defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system))
    9081     (declare (ignorable o s)) nil)
    9082   (defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system))
    9083     (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
    9084   (defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system))
    9085     (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
    9086   (defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system))
    9087     (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s))))
    9088 
    9089 ;;;; -------------------------------------------------------------------------
    9090 ;;; Backward-compatible interfaces
    9091 
    9092 (asdf/package:define-package :asdf/backward-interface
    9093   (:recycle :asdf/backward-interface :asdf)
    9094   (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
    9095    :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
    9096    :asdf/lisp-build :asdf/operate :asdf/output-translations)
    9097   (:export
    9098    #:*asdf-verbose*
    9099    #:operation-error #:compile-error #:compile-failed #:compile-warned
    9100    #:error-component #:error-operation
    9101    #:component-load-dependencies
    9102    #:enable-asdf-binary-locations-compatibility
    9103    #:operation-forced
    9104    #:operation-on-failure
    9105    #:operation-on-warnings
    9106    #:component-property
    9107    #:run-shell-command
    9108    #:system-definition-pathname))
    9109 (in-package :asdf/backward-interface)
    9110 
    9111 (with-upgradability ()
    9112   (define-condition operation-error (error) ;; Bad, backward-compatible name
    9113     ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
    9114     ((component :reader error-component :initarg :component)
    9115      (operation :reader error-operation :initarg :operation))
    9116     (:report (lambda (c s)
    9117                (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
    9118                        (type-of c) (error-operation c) (error-component c)))))
    9119   (define-condition compile-error (operation-error) ())
    9120   (define-condition compile-failed (compile-error) ())
    9121   (define-condition compile-warned (compile-error) ())
    9122 
    9123   (defun component-load-dependencies (component)
    9124     ;; Old deprecated name for the same thing. Please update your software.
    9125     (component-sibling-dependencies component))
    9126 
    9127   (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
    9128   (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
    9129 
    9130   (defgeneric operation-on-warnings (operation))
    9131   (defgeneric operation-on-failure (operation))
    9132   #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
    9133   #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
    9134   (defmethod operation-on-warnings ((o operation))
    9135     (declare (ignorable o)) *compile-file-warnings-behaviour*)
    9136   (defmethod operation-on-failure ((o operation))
    9137     (declare (ignorable o)) *compile-file-failure-behaviour*)
    9138   (defmethod (setf operation-on-warnings) (x (o operation))
    9139     (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
    9140   (defmethod (setf operation-on-failure) (x (o operation))
    9141     (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
    9142 
    9143   (defun system-definition-pathname (x)
    9144     ;; As of 2.014.8, we mean to make this function obsolete,
    9145     ;; but that won't happen until all clients have been updated.
    9146     ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
    9147     "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
    9148 It used to expose ASDF internals with subtle differences with respect to
    9149 user expectations, that have been refactored away since.
    9150 We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
    9151 for a mostly compatible replacement that we're supporting,
    9152 or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
    9153 if that's whay you mean." ;;)
    9154     (system-source-file x)))
    9155 
    9156 
    9157 ;;;; ASDF-Binary-Locations compatibility
    9158 ;; This remains supported for legacy user, but not recommended for new users.
    9159 (with-upgradability ()
    9160   (defun enable-asdf-binary-locations-compatibility
    9161       (&key
    9162        (centralize-lisp-binaries nil)
    9163        (default-toplevel-directory
    9164         (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
    9165        (include-per-user-information nil)
    9166        (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
    9167        (source-to-target-mappings nil)
    9168        (file-types `(,(compile-file-type)
    9169                      "build-report"
    9170                      #+ecl (compile-file-type :type :object)
    9171                      #+mkcl (compile-file-type :fasl-p nil)
    9172                      #+clisp "lib" #+sbcl "cfasl"
    9173                      #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
    9174     #+(or clisp ecl mkcl)
    9175     (when (null map-all-source-files)
    9176       (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
    9177     (let* ((patterns (if map-all-source-files (list *wild-file*)
    9178                          (loop :for type :in file-types
    9179                                :collect (make-pathname :type type :defaults *wild-file*))))
    9180            (destination-directory
    9181              (if centralize-lisp-binaries
    9182                  `(,default-toplevel-directory
    9183                    ,@(when include-per-user-information
    9184                        (cdr (pathname-directory (user-homedir-pathname))))
    9185                    :implementation ,*wild-inferiors*)
    9186                  `(:root ,*wild-inferiors* :implementation))))
    9187       (initialize-output-translations
    9188        `(:output-translations
    9189          ,@source-to-target-mappings
    9190          #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    9191          #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
    9192          ,@(loop :for pattern :in patterns
    9193                  :collect `((:root ,*wild-inferiors* ,pattern)
    9194                             (,@destination-directory ,pattern)))
    9195          (t t)
    9196          :ignore-inherited-configuration))))
    9197 
    9198   (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
    9199     (declare (ignorable operation-class system args))
    9200     (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
    9201       (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
    9202 ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
    9203 which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
    9204 and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
    9205 In case you insist on preserving your previous A-B-L configuration, but
    9206 do not know how to achieve the same effect with A-O-T, you may use function
    9207 ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
    9208 call that function where you would otherwise have loaded and configured A-B-L."))))
    9209 
    9210 
    9211 ;;; run-shell-command
    9212 ;; WARNING! The function below is not just deprecated but also dysfunctional.
    9213 ;; Please use asdf/run-program:run-program instead.
    9214 (with-upgradability ()
    9215   (defun run-shell-command (control-string &rest args)
    9216     "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    9217 synchronously execute the result using a Bourne-compatible shell, with
    9218 output to *VERBOSE-OUT*.  Returns the shell's exit code.
    9219 
    9220 PLEASE DO NOT USE.
    9221 Deprecated function, for backward-compatibility only.
    9222 Please use ASDF-DRIVER:RUN-PROGRAM instead."
    9223     (let ((command (apply 'format nil control-string args)))
    9224       (asdf-message "; $ ~A~%" command)
    9225       (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
    9226 
    9227 (with-upgradability ()
    9228   (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
    9229 
    9230 ;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
    9231 (with-upgradability ()
    9232   (defgeneric component-property (component property))
    9233   (defgeneric (setf component-property) (new-value component property))
    9234 
    9235   (defmethod component-property ((c component) property)
    9236     (cdr (assoc property (slot-value c 'properties) :test #'equal)))
    9237 
    9238   (defmethod (setf component-property) (new-value (c component) property)
    9239     (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    9240       (if a
    9241           (setf (cdr a) new-value)
    9242           (setf (slot-value c 'properties)
    9243                 (acons property new-value (slot-value c 'properties)))))
    9244     new-value))
    92459498;;;; ---------------------------------------------------------------------------
    92469499;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     
    92649517  (:export
    92659518   #:defsystem #:find-system #:locate-system #:coerce-name
    9266    #:oos #:operate #:traverse #:perform-plan
     9519   #:oos #:operate #:traverse #:perform-plan #:sequential-plan
    92679520   #:system-definition-pathname #:with-system-definitions
    92689521   #:search-for-system-definition #:find-component #:component-find-path
    92699522   #:compile-system #:load-system #:load-systems
    92709523   #:require-system #:test-system #:clear-system
    9271    #:operation #:upward-operation #:downward-operation #:make-operation
     9524   #:operation #:make-operation #:find-operation
     9525   #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
    92729526   #:build-system #:build-op
    92739527   #:load-op #:prepare-op #:compile-op
     
    92769530   #:implementation-identifier #:implementation-type #:hostname
    92779531   #:input-files #:output-files #:output-file #:perform
    9278    #:operation-done-p #:explain #:action-description #:component-sibling-dependencies
     9532   #:operation-done-p #:explain #:action-description #:component-sideway-dependencies
    92799533   #:needed-in-image-p
    92809534   ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT.
    92819535   #:component-load-dependencies #:run-shell-command ; deprecated, do not use
    9282    #:bundle-op #:precompiled-system #:compiled-file #:bundle-system
     9536   #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
    92839537   #+ecl #:make-build
    9284    #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op
     9538   #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
     9539   #:lib-op #:dll-op #:binary-op #:program-op
     9540   #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op
    92859541   #:concatenate-source-op
    92869542   #:load-concatenated-source-op
     
    93589614   #:missing-dependency-of-version
    93599615   #:circular-dependency        ; errors
    9360    #:duplicate-names
     9616   #:duplicate-names #:non-toplevel-system #:non-system-system
    93619617
    93629618   #:try-recompiling
     
    93929648   #:resolve-location
    93939649   #:asdf-message
     9650   #:*user-cache*
    93949651   #:user-output-translations-pathname
    93959652   #:system-output-translations-pathname
Note: See TracChangeset for help on using the changeset viewer.