source: trunk/abcl/src/org/armedbear/lisp/asdf.lisp @ 13704

Last change on this file since 13704 was 13704, checked in by Mark Evenson, 10 years ago

Fix #181: TRUENAME doesn't always canonicalize the outer DEVICE component of JAR-PATHNAME.

If *DEFAULT-PATHNAME-DEFAULTS* is a JAR-PATHNAME, then TRUENAME will
not attempt to canonicalize the outer DEVICE component of a JAR-PATHNAME.

Remove corresponding kludge from ASDF.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 182.2 KB
Line 
1;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2;;; This is ASDF 2.019: Another System Definition Facility.
3;;;
4;;; Feedback, bug reports, and patches are all welcome:
5;;; please mail to <asdf-devel@common-lisp.net>.
6;;; Note first that the canonical source for ASDF is presently
7;;; <URL:http://common-lisp.net/project/asdf/>.
8;;;
9;;; If you obtained this copy from anywhere else, and you experience
10;;; trouble using it, or find bugs, you may want to check at the
11;;; location above for a more recent version (and for documentation
12;;; and test files, if your copy came without them) before reporting
13;;; bugs.  There are usually two "supported" revisions - the git master
14;;; branch is the latest development version, whereas the git release
15;;; branch may be slightly older but is considered `stable'
16
17;;; -- LICENSE START
18;;; (This is the MIT / X Consortium license as taken from
19;;;  http://www.opensource.org/licenses/mit-license.html on or about
20;;;  Monday; July 13, 2009)
21;;;
22;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
23;;;
24;;; Permission is hereby granted, free of charge, to any person obtaining
25;;; a copy of this software and associated documentation files (the
26;;; "Software"), to deal in the Software without restriction, including
27;;; without limitation the rights to use, copy, modify, merge, publish,
28;;; distribute, sublicense, and/or sell copies of the Software, and to
29;;; permit persons to whom the Software is furnished to do so, subject to
30;;; the following conditions:
31;;;
32;;; The above copyright notice and this permission notice shall be
33;;; included in all copies or substantial portions of the Software.
34;;;
35;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
36;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
37;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
38;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
39;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
40;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
41;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
42;;;
43;;; -- LICENSE END
44
45;;; The problem with writing a defsystem replacement is bootstrapping:
46;;; we can't use defsystem to compile it.  Hence, all in one file.
47
48#+xcvb (module ())
49
50(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
51
52#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
53(error "ASDF is not supported on your implementation. Please help us port it.")
54
55#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
56
57(eval-when (:compile-toplevel :load-toplevel :execute)
58  ;;; Implementation-dependent tweaks
59  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
60  #+allegro
61  (setf excl::*autoload-package-name-alist*
62        (remove "asdf" excl::*autoload-package-name-alist*
63                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
64  #+ecl (unless (member :ecl-bytecmp *features*) (require :cmp))
65  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
66  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
67            (and (= system::*gcl-major-version* 2)
68                 (< system::*gcl-minor-version* 7)))
69    (pushnew :gcl-pre2.7 *features*))
70  ;;; make package if it doesn't exist yet.
71  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
72  (unless (find-package :asdf)
73    (make-package :asdf :use '(:common-lisp))))
74
75(in-package :asdf)
76
77;;;; Create packages in a way that is compatible with hot-upgrade.
78;;;; See https://bugs.launchpad.net/asdf/+bug/485687
79;;;; See more near the end of the file.
80
81(eval-when (:load-toplevel :compile-toplevel :execute)
82  (defvar *asdf-version* nil)
83  (defvar *upgraded-p* nil)
84  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
85  (defun find-symbol* (s p)
86    (find-symbol (string s) p))
87  ;; Strip out formatting that is not supported on Genera.
88  ;; Has to be inside the eval-when to make Lispworks happy (!)
89  (defun strcat (&rest strings)
90    (apply 'concatenate 'string strings))
91  (defmacro compatfmt (format)
92    #-(or gcl genera) format
93    #+(or gcl genera)
94    (loop :for (unsupported . replacement) :in
95      (append
96       '(("~3i~_" . ""))
97       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
98      (loop :for found = (search unsupported format) :while found :do
99        (setf format (strcat (subseq format 0 found) replacement
100                             (subseq format (+ found (length unsupported)))))))
101    format)
102  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
103         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
104         ;; can help you do these changes in synch (look at the source for documentation).
105         ;; Relying on its automation, the version is now redundantly present on top of this file.
106         ;; "2.345" would be an official release
107         ;; "2.345.6" would be a development version in the official upstream
108         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
109         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
110         (asdf-version "2.019")
111         (existing-asdf (find-class 'component nil))
112         (existing-version *asdf-version*)
113         (already-there (equal asdf-version existing-version)))
114    (unless (and existing-asdf already-there)
115      (when (and existing-asdf *asdf-verbose*)
116        (format *trace-output*
117                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
118                existing-version asdf-version))
119      (labels
120          ((present-symbol-p (symbol package)
121             (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
122           (present-symbols (package)
123             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
124             (let (l)
125               (do-symbols (s package)
126                 (when (present-symbol-p s package) (push s l)))
127               (reverse l)))
128           (unlink-package (package)
129             (let ((u (find-package package)))
130               (when u
131                 (ensure-unintern u (present-symbols u))
132                 (loop :for p :in (package-used-by-list u) :do
133                   (unuse-package u p))
134                 (delete-package u))))
135           (ensure-exists (name nicknames use)
136             (let ((previous
137                    (remove-duplicates
138                     (mapcar #'find-package (cons name nicknames))
139                     :from-end t)))
140               ;; do away with packages with conflicting (nick)names
141               (map () #'unlink-package (cdr previous))
142               ;; reuse previous package with same name
143               (let ((p (car previous)))
144                 (cond
145                   (p
146                    (rename-package p name nicknames)
147                    (ensure-use p use)
148                    p)
149                   (t
150                    (make-package name :nicknames nicknames :use use))))))
151           (intern* (symbol package)
152             (intern (string symbol) package))
153           (remove-symbol (symbol package)
154             (let ((sym (find-symbol* symbol package)))
155               (when sym
156                 #-cormanlisp (unexport sym package)
157                 (unintern sym package)
158                 sym)))
159           (ensure-unintern (package symbols)
160             (loop :with packages = (list-all-packages)
161               :for sym :in symbols
162               :for removed = (remove-symbol sym package)
163               :when removed :do
164               (loop :for p :in packages :do
165                 (when (eq removed (find-symbol* sym p))
166                   (unintern removed p)))))
167           (ensure-shadow (package symbols)
168             (shadow symbols package))
169           (ensure-use (package use)
170             (dolist (used (reverse use))
171               (do-external-symbols (sym used)
172                 (unless (eq sym (find-symbol* sym package))
173                   (remove-symbol sym package)))
174               (use-package used package)))
175           (ensure-fmakunbound (package symbols)
176             (loop :for name :in symbols
177               :for sym = (find-symbol* name package)
178               :when sym :do (fmakunbound sym)))
179           (ensure-export (package export)
180             (let ((formerly-exported-symbols nil)
181                   (bothly-exported-symbols nil)
182                   (newly-exported-symbols nil))
183               (do-external-symbols (sym package)
184                 (if (member sym export :test 'string-equal)
185                     (push sym bothly-exported-symbols)
186                     (push sym formerly-exported-symbols)))
187               (loop :for sym :in export :do
188                 (unless (member sym bothly-exported-symbols :test 'equal)
189                   (push sym newly-exported-symbols)))
190               (loop :for user :in (package-used-by-list package)
191                 :for shadowing = (package-shadowing-symbols user) :do
192                 (loop :for new :in newly-exported-symbols
193                   :for old = (find-symbol* new user)
194                   :when (and old (not (member old shadowing)))
195                   :do (unintern old user)))
196               (loop :for x :in newly-exported-symbols :do
197                 (export (intern* x package)))))
198           (ensure-package (name &key nicknames use unintern
199                                 shadow export redefined-functions)
200             (let* ((p (ensure-exists name nicknames use)))
201               (ensure-unintern p unintern)
202               (ensure-shadow p shadow)
203               (ensure-export p export)
204               (ensure-fmakunbound p redefined-functions)
205               p)))
206        (macrolet
207            ((pkgdcl (name &key nicknames use export
208                           redefined-functions unintern shadow)
209                 `(ensure-package
210                   ',name :nicknames ',nicknames :use ',use :export ',export
211                   :shadow ',shadow
212                   :unintern ',unintern
213                   :redefined-functions ',redefined-functions)))
214          (pkgdcl
215           :asdf
216           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
217           :use (:common-lisp)
218           :redefined-functions
219           (#:perform #:explain #:output-files #:operation-done-p
220            #:perform-with-restarts #:component-relative-pathname
221            #:system-source-file #:operate #:find-component #:find-system
222            #:apply-output-translations #:translate-pathname* #:resolve-location
223            #:system-relative-pathname
224            #:inherit-source-registry #:process-source-registry
225            #:process-source-registry-directive
226            #:compile-file* #:source-file-type)
227           :unintern
228           (#:*asdf-revision* #:around #:asdf-method-combination
229            #:split #:make-collector #:do-dep #:do-one-dep
230            #:resolve-relative-location-component #:resolve-absolute-location-component
231            #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
232           :export
233           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
234            #:system-definition-pathname #:with-system-definitions
235            #:search-for-system-definition #:find-component #:component-find-path
236            #:compile-system #:load-system #:load-systems #:test-system #:clear-system
237            #:operation #:compile-op #:load-op #:load-source-op #:test-op
238            #:feature #:version #:version-satisfies
239            #:upgrade-asdf
240            #:implementation-identifier #:implementation-type
241            #:input-files #:output-files #:output-file #:perform
242            #:operation-done-p #:explain
243
244            #:component #:source-file
245            #:c-source-file #:cl-source-file #:java-source-file
246            #:cl-source-file.cl #:cl-source-file.lsp
247            #:static-file
248            #:doc-file
249            #:html-file
250            #:text-file
251            #:source-file-type
252            #:module                     ; components
253            #:system
254            #:unix-dso
255
256            #:module-components          ; component accessors
257            #:module-components-by-name  ; component accessors
258            #:component-pathname
259            #:component-relative-pathname
260            #:component-name
261            #:component-version
262            #:component-parent
263            #:component-property
264            #:component-system
265
266            #:component-depends-on
267
268            #:system-description
269            #:system-long-description
270            #:system-author
271            #:system-maintainer
272            #:system-license
273            #:system-licence
274            #:system-source-file
275            #:system-source-directory
276            #:system-relative-pathname
277            #:map-systems
278
279            #:operation-description
280            #:operation-on-warnings
281            #:operation-on-failure
282            #:component-visited-p
283            ;;#:*component-parent-pathname*
284            #:*system-definition-search-functions*
285            #:*central-registry*         ; variables
286            #:*compile-file-warnings-behaviour*
287            #:*compile-file-failure-behaviour*
288            #:*resolve-symlinks*
289            #:*require-asdf-operator*
290            #:*asdf-verbose*
291            #:*verbose-out*
292
293            #:asdf-version
294
295            #:operation-error #:compile-failed #:compile-warned #:compile-error
296            #:error-name
297            #:error-pathname
298            #:load-system-definition-error
299            #:error-component #:error-operation
300            #:system-definition-error
301            #:missing-component
302            #:missing-component-of-version
303            #:missing-dependency
304            #:missing-dependency-of-version
305            #:circular-dependency        ; errors
306            #:duplicate-names
307
308            #:try-recompiling
309            #:retry
310            #:accept                     ; restarts
311            #:coerce-entry-to-directory
312            #:remove-entry-from-registry
313
314            #:clear-configuration
315            #:*output-translations-parameter*
316            #:initialize-output-translations
317            #:disable-output-translations
318            #:clear-output-translations
319            #:ensure-output-translations
320            #:apply-output-translations
321            #:compile-file*
322            #:compile-file-pathname*
323            #:enable-asdf-binary-locations-compatibility
324            #:*default-source-registries*
325            #:*source-registry-parameter*
326            #:initialize-source-registry
327            #:compute-source-registry
328            #:clear-source-registry
329            #:ensure-source-registry
330            #:process-source-registry
331            #:system-registered-p
332            #:asdf-message
333            #:user-output-translations-pathname
334            #:system-output-translations-pathname
335            #:user-output-translations-directory-pathname
336            #:system-output-translations-directory-pathname
337            #:user-source-registry
338            #:system-source-registry
339            #:user-source-registry-directory
340            #:system-source-registry-directory
341
342            ;; Utilities
343            #:absolute-pathname-p
344            ;; #:aif #:it
345            ;; #:appendf #:orf
346            #:coerce-name
347            #:directory-pathname-p
348            ;; #:ends-with
349            #:ensure-directory-pathname
350            #:getenv
351            ;; #:length=n-p
352            ;; #:find-symbol*
353            #:merge-pathnames* #:coerce-pathname #:subpathname
354            #:pathname-directory-pathname
355            #:read-file-forms
356            ;; #:remove-keys
357            ;; #:remove-keyword
358            #:resolve-symlinks
359            #:split-string
360            #:component-name-to-pathname-components
361            #:split-name-type
362            #:subdirectories
363            #:truenamize
364            #:while-collecting)))
365        #+genera (import 'scl:boolean :asdf)
366        (setf *asdf-version* asdf-version
367              *upgraded-p* (if existing-version
368                               (cons existing-version *upgraded-p*)
369                               *upgraded-p*))))))
370
371;;;; -------------------------------------------------------------------------
372;;;; User-visible parameters
373;;;;
374(defvar *resolve-symlinks* t
375  "Determine whether or not ASDF resolves symlinks when defining systems.
376
377Defaults to T.")
378
379(defvar *compile-file-warnings-behaviour*
380  (or #+clisp :ignore :warn)
381  "How should ASDF react if it encounters a warning when compiling a file?
382Valid values are :error, :warn, and :ignore.")
383
384(defvar *compile-file-failure-behaviour*
385  (or #+sbcl :error #+clisp :ignore :warn)
386  "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
387when compiling a file?  Valid values are :error, :warn, and :ignore.
388Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
389
390(defvar *verbose-out* nil)
391
392(defparameter +asdf-methods+
393  '(perform-with-restarts perform explain output-files operation-done-p))
394
395#+allegro
396(eval-when (:compile-toplevel :execute)
397  (defparameter *acl-warn-save*
398                (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
399                  excl:*warn-on-nested-reader-conditionals*))
400  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
401    (setf excl:*warn-on-nested-reader-conditionals* nil)))
402
403;;;; -------------------------------------------------------------------------
404;;;; Resolve forward references
405
406(declaim (ftype (function (t) t)
407                format-arguments format-control
408                error-name error-pathname error-condition
409                duplicate-names-name
410                error-component error-operation
411                module-components module-components-by-name
412                circular-dependency-components
413                condition-arguments condition-form
414                condition-format condition-location
415                coerce-name)
416         (ftype (function (&optional t) (values)) initialize-source-registry)
417         #-(or cormanlisp gcl-pre2.7)
418         (ftype (function (t t) t) (setf module-components-by-name)))
419
420;;;; -------------------------------------------------------------------------
421;;;; Compatibility various implementations
422#+cormanlisp
423(progn
424  (deftype logical-pathname () nil)
425  (defun make-broadcast-stream () *error-output*)
426  (defun file-namestring (p)
427    (setf p (pathname p))
428    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
429
430#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
431      (read-from-string
432       "(eval-when (:compile-toplevel :load-toplevel :execute)
433          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
434          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
435          ;; Note: ASDF may expect user-homedir-pathname to provide
436          ;; the pathname of the current user's home directory, whereas
437          ;; MCL by default provides the directory from which MCL was started.
438          ;; See http://code.google.com/p/mcl/wiki/Portability
439          (defun current-user-homedir-pathname ()
440            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
441          (defun probe-posix (posix-namestring)
442            \"If a file exists for the posix namestring, return the pathname\"
443            (ccl::with-cstrs ((cpath posix-namestring))
444              (ccl::rlet ((is-dir :boolean)
445                          (fsref :fsref))
446                (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
447                  (ccl::%path-from-fsref fsref is-dir))))))"))
448
449;;;; -------------------------------------------------------------------------
450;;;; General Purpose Utilities
451
452(macrolet
453    ((defdef (def* def)
454       `(defmacro ,def* (name formals &rest rest)
455          `(progn
456             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
457             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
458             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
459                `(declaim (notinline ,name)))
460             (,',def ,name ,formals ,@rest)))))
461  (defdef defgeneric* defgeneric)
462  (defdef defun* defun))
463
464(defmacro while-collecting ((&rest collectors) &body body)
465  "COLLECTORS should be a list of names for collections.  A collector
466defines a function that, when applied to an argument inside BODY, will
467add its argument to the corresponding collection.  Returns multiple values,
468a list for each collection, in order.
469   E.g.,
470\(while-collecting \(foo bar\)
471           \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
472             \(foo \(first x\)\)
473             \(bar \(second x\)\)\)\)
474Returns two values: \(A B C\) and \(1 2 3\)."
475  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
476        (initial-values (mapcar (constantly nil) collectors)))
477    `(let ,(mapcar #'list vars initial-values)
478       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
479         ,@body
480         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
481
482(defmacro aif (test then &optional else)
483  `(let ((it ,test)) (if it ,then ,else)))
484
485(defun* pathname-directory-pathname (pathname)
486  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
487and NIL NAME, TYPE and VERSION components"
488  (when pathname
489    (make-pathname :name nil :type nil :version nil :defaults pathname)))
490
491(defun* normalize-pathname-directory-component (directory)
492  (cond
493    #-(or cmu sbcl scl)
494    ((stringp directory) `(:absolute ,directory) directory)
495    #+gcl
496    ((and (consp directory) (stringp (first directory)))
497     `(:absolute ,@directory))
498    ((or (null directory)
499         (and (consp directory) (member (first directory) '(:absolute :relative))))
500     directory)
501    (t
502     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
503
504(defun* merge-pathname-directory-components (specified defaults)
505  (let ((directory (normalize-pathname-directory-component specified)))
506    (ecase (first directory)
507      ((nil) defaults)
508      (:absolute specified)
509      (:relative
510       (let ((defdir (normalize-pathname-directory-component defaults))
511             (reldir (cdr directory)))
512         (cond
513           ((null defdir)
514            directory)
515           ((not (eq :back (first reldir)))
516            (append defdir reldir))
517           (t
518            (loop :with defabs = (first defdir)
519              :with defrev = (reverse (rest defdir))
520              :while (and (eq :back (car reldir))
521                          (or (and (eq :absolute defabs) (null defrev))
522                              (stringp (car defrev))))
523              :do (pop reldir) (pop defrev)
524              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
525
526(defun* ununspecific (x)
527  (if (eq x :unspecific) nil x))
528
529(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
530  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
531if the SPECIFIED pathname does not have an absolute directory,
532then the HOST and DEVICE both come from the DEFAULTS, whereas
533if the SPECIFIED pathname does have an absolute directory,
534then the HOST and DEVICE both come from the SPECIFIED.
535Also, if either argument is NIL, then the other argument is returned unmodified."
536  (when (null specified) (return-from merge-pathnames* defaults))
537  (when (null defaults) (return-from merge-pathnames* specified))
538  #+scl
539  (ext:resolve-pathname specified defaults)
540  #-scl
541  (let* ((specified (pathname specified))
542         (defaults (pathname defaults))
543         (directory (normalize-pathname-directory-component (pathname-directory specified)))
544         (name (or (pathname-name specified) (pathname-name defaults)))
545         (type (or (pathname-type specified) (pathname-type defaults)))
546         (version (or (pathname-version specified) (pathname-version defaults))))
547    (labels ((unspecific-handler (p)
548               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
549      (multiple-value-bind (host device directory unspecific-handler)
550          (ecase (first directory)
551            ((:absolute)
552             (values (pathname-host specified)
553                     (pathname-device specified)
554                     directory
555                     (unspecific-handler specified)))
556            ((nil :relative)
557             (values (pathname-host defaults)
558                     (pathname-device defaults)
559                     (merge-pathname-directory-components directory (pathname-directory defaults))
560                     (unspecific-handler defaults))))
561        (make-pathname :host host :device device :directory directory
562                       :name (funcall unspecific-handler name)
563                       :type (funcall unspecific-handler type)
564                       :version (funcall unspecific-handler version))))))
565
566(defun* pathname-parent-directory-pathname (pathname)
567  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
568and NIL NAME, TYPE and VERSION components"
569  (when pathname
570    (make-pathname :name nil :type nil :version nil
571                   :directory (merge-pathname-directory-components
572                               '(:relative :back) (pathname-directory pathname))
573                   :defaults pathname)))
574
575(define-modify-macro appendf (&rest args)
576  append "Append onto list") ;; only to be used on short lists.
577
578(define-modify-macro orf (&rest args)
579  or "or a flag")
580
581(defun* first-char (s)
582  (and (stringp s) (plusp (length s)) (char s 0)))
583
584(defun* last-char (s)
585  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
586
587
588(defun* asdf-message (format-string &rest format-args)
589  (declare (dynamic-extent format-args))
590  (apply 'format *verbose-out* format-string format-args))
591
592(defun* split-string (string &key max (separator '(#\Space #\Tab)))
593  "Split STRING into a list of components separated by
594any of the characters in the sequence SEPARATOR.
595If MAX is specified, then no more than max(1,MAX) components will be returned,
596starting the separation from the end, e.g. when called with arguments
597 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
598  (catch nil
599    (let ((list nil) (words 0) (end (length string)))
600      (flet ((separatorp (char) (find char separator))
601             (done () (throw nil (cons (subseq string 0 end) list))))
602        (loop
603          :for start = (if (and max (>= words (1- max)))
604                           (done)
605                           (position-if #'separatorp string :end end :from-end t)) :do
606          (when (null start)
607            (done))
608          (push (subseq string (1+ start) end) list)
609          (incf words)
610          (setf end start))))))
611
612(defun* split-name-type (filename)
613  (let ((unspecific
614         ;; Giving :unspecific as argument to make-pathname is not portable.
615         ;; See CLHS make-pathname and 19.2.2.2.3.
616         ;; We only use it on implementations that support it.
617         (or #+(or clozure gcl lispworks sbcl) :unspecific)))
618    (destructuring-bind (name &optional (type unspecific))
619        (split-string filename :max 2 :separator ".")
620      (if (equal name "")
621          (values filename unspecific)
622          (values name type)))))
623
624(defun* component-name-to-pathname-components (s &key force-directory force-relative)
625  "Splits the path string S, returning three values:
626A flag that is either :absolute or :relative, indicating
627   how the rest of the values are to be interpreted.
628A directory path --- a list of strings, suitable for
629   use with MAKE-PATHNAME when prepended with the flag
630   value.
631A filename with type extension, possibly NIL in the
632   case of a directory pathname.
633FORCE-DIRECTORY forces S to be interpreted as a directory
634pathname \(third return value will be NIL, final component
635of S will be treated as part of the directory path.
636
637The intention of this function is to support structured component names,
638e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
639pathnames."
640  (check-type s string)
641  (when (find #\: s)
642    (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
643  (let* ((components (split-string s :separator "/"))
644         (last-comp (car (last components))))
645    (multiple-value-bind (relative components)
646        (if (equal (first components) "")
647            (if (equal (first-char s) #\/)
648                (progn
649                  (when force-relative
650                    (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
651                  (values :absolute (cdr components)))
652                (values :relative nil))
653          (values :relative components))
654      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
655      (setf components (substitute :back ".." components :test #'equal))
656      (cond
657        ((equal last-comp "")
658         (values relative components nil)) ; "" already removed
659        (force-directory
660         (values relative components nil))
661        (t
662         (values relative (butlast components) last-comp))))))
663
664(defun* remove-keys (key-names args)
665  (loop :for (name val) :on args :by #'cddr
666    :unless (member (symbol-name name) key-names
667                    :key #'symbol-name :test 'equal)
668    :append (list name val)))
669
670(defun* remove-keyword (key args)
671  (loop :for (k v) :on args :by #'cddr
672    :unless (eq k key)
673    :append (list k v)))
674
675(defun* getenv (x)
676  (declare (ignorable x))
677  #+(or abcl clisp ecl xcl) (ext:getenv x)
678  #+allegro (sys:getenv x)
679  #+clozure (ccl:getenv x)
680  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
681  #+cormanlisp
682  (let* ((buffer (ct:malloc 1))
683         (cname (ct:lisp-string-to-c-string x))
684         (needed-size (win:getenvironmentvariable cname buffer 0))
685         (buffer1 (ct:malloc (1+ needed-size))))
686    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
687               nil
688               (ct:c-string-to-lisp-string buffer1))
689      (ct:free buffer)
690      (ct:free buffer1)))
691  #+gcl (system:getenv x)
692  #+genera nil
693  #+lispworks (lispworks:environment-variable x)
694  #+mcl (ccl:with-cstrs ((name x))
695          (let ((value (_getenv name)))
696            (unless (ccl:%null-ptr-p value)
697              (ccl:%get-cstring value))))
698  #+sbcl (sb-ext:posix-getenv x)
699  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
700  (error "~S is not supported on your implementation" 'getenv))
701
702(defun* directory-pathname-p (pathname)
703  "Does PATHNAME represent a directory?
704
705A directory-pathname is a pathname _without_ a filename. The three
706ways that the filename components can be missing are for it to be NIL,
707:UNSPECIFIC or the empty string.
708
709Note that this does _not_ check to see that PATHNAME points to an
710actually-existing directory."
711  (when pathname
712    (let ((pathname (pathname pathname)))
713      (flet ((check-one (x)
714               (member x '(nil :unspecific "") :test 'equal)))
715        (and (not (wild-pathname-p pathname))
716             (check-one (pathname-name pathname))
717             (check-one (pathname-type pathname))
718             t)))))
719
720(defun* ensure-directory-pathname (pathspec)
721  "Converts the non-wild pathname designator PATHSPEC to directory form."
722  (cond
723   ((stringp pathspec)
724    (ensure-directory-pathname (pathname pathspec)))
725   ((not (pathnamep pathspec))
726    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
727   ((wild-pathname-p pathspec)
728    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
729   ((directory-pathname-p pathspec)
730    pathspec)
731   (t
732    (make-pathname :directory (append (or (pathname-directory pathspec)
733                                          (list :relative))
734                                      (list (file-namestring pathspec)))
735                   :name nil :type nil :version nil
736                   :defaults pathspec))))
737
738#+genera
739(unless (fboundp 'ensure-directories-exist)
740  (defun* ensure-directories-exist (path)
741    (fs:create-directories-recursively (pathname path))))
742
743(defun* absolute-pathname-p (pathspec)
744  (and (typep pathspec '(or pathname string))
745       (eq :absolute (car (pathname-directory (pathname pathspec))))))
746
747(defun* length=n-p (x n) ;is it that (= (length x) n) ?
748  (check-type n (integer 0 *))
749  (loop
750    :for l = x :then (cdr l)
751    :for i :downfrom n :do
752    (cond
753      ((zerop i) (return (null l)))
754      ((not (consp l)) (return nil)))))
755
756(defun* ends-with (s suffix)
757  (check-type s string)
758  (check-type suffix string)
759  (let ((start (- (length s) (length suffix))))
760    (and (<= 0 start)
761         (string-equal s suffix :start1 start))))
762
763(defun* read-file-forms (file)
764  (with-open-file (in file)
765    (loop :with eof = (list nil)
766     :for form = (read in nil eof)
767     :until (eq form eof)
768     :collect form)))
769
770(defun* pathname-root (pathname)
771  (make-pathname :directory '(:absolute)
772                 :name nil :type nil :version nil
773                 :defaults pathname ;; host device, and on scl, *some*
774                 ;; scheme-specific parts: port username password, not others:
775                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
776
777(defun* probe-file* (p)
778  "when given a pathname P, probes the filesystem for a file or directory
779with given pathname and if it exists return its truename."
780  (etypecase p
781    (null nil)
782    (string (probe-file* (parse-namestring p)))
783    (pathname (unless (wild-pathname-p p)
784                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
785                      '(probe-file p)
786                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
787                                   `(ignore-errors (,it p)))
788                      '(ignore-errors (truename p)))))))
789
790(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
791  "Resolve as much of a pathname as possible"
792  (block nil
793    (when (typep pathname '(or null logical-pathname)) (return pathname))
794    (let ((p (merge-pathnames* pathname defaults)))
795      (when (typep p 'logical-pathname) (return p))
796      (let ((found (probe-file* p)))
797        (when found (return found)))
798      (unless (absolute-pathname-p p)
799        (let ((true-defaults (ignore-errors (truename defaults))))
800          (when true-defaults
801            (setf p (merge-pathnames pathname true-defaults)))))
802      (unless (absolute-pathname-p p) (return p))
803      (let ((sofar (probe-file* (pathname-root p))))
804        (unless sofar (return p))
805        (flet ((solution (directories)
806                 (merge-pathnames*
807                  (make-pathname :host nil :device nil
808                                 :directory `(:relative ,@directories)
809                                 :name (pathname-name p)
810                                 :type (pathname-type p)
811                                 :version (pathname-version p))
812                  sofar)))
813          (loop :with directory = (normalize-pathname-directory-component
814                                   (pathname-directory p))
815            :for component :in (cdr directory)
816            :for rest :on (cdr directory)
817            :for more = (probe-file*
818                         (merge-pathnames*
819                          (make-pathname :directory `(:relative ,component))
820                          sofar)) :do
821            (if more
822                (setf sofar more)
823                (return (solution rest)))
824            :finally
825            (return (solution nil))))))))
826
827(defun* resolve-symlinks (path)
828  #-allegro (truenamize path)
829  #+allegro (if (typep path 'logical-pathname)
830                path
831                (excl:pathname-resolve-symbolic-links path)))
832
833(defun* resolve-symlinks* (path)
834  (if *resolve-symlinks*
835      (and path (resolve-symlinks path))
836      path))
837
838(defun* ensure-pathname-absolute (path)
839  (cond
840    ((absolute-pathname-p path) path)
841    ((stringp path) (ensure-pathname-absolute (pathname path)))
842    ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
843    (t (let ((resolved (resolve-symlinks path)))
844         (assert (absolute-pathname-p resolved))
845         resolved))))
846
847(defun* default-directory ()
848  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
849
850(defun* lispize-pathname (input-file)
851  (make-pathname :type "lisp" :defaults input-file))
852
853(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
854(defparameter *wild-file*
855  (make-pathname :name *wild* :type *wild*
856                 :version (or #-(or abcl xcl) *wild*) :directory nil))
857(defparameter *wild-directory*
858  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
859(defparameter *wild-inferiors*
860  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
861(defparameter *wild-path*
862  (merge-pathnames *wild-file* *wild-inferiors*))
863
864(defun* wilden (path)
865  (merge-pathnames* *wild-path* path))
866
867#-scl
868(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
869  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
870    (last-char (namestring foo))))
871
872#-scl
873(defun* directorize-pathname-host-device (pathname)
874  (let* ((root (pathname-root pathname))
875         (wild-root (wilden root))
876         (absolute-pathname (merge-pathnames* pathname root))
877         (separator (directory-separator-for-host root))
878         (root-namestring (namestring root))
879         (root-string
880          (substitute-if #\/
881                         #'(lambda (x) (or (eql x #\:)
882                                           (eql x separator)))
883                         root-namestring)))
884    (multiple-value-bind (relative path filename)
885        (component-name-to-pathname-components root-string :force-directory t)
886      (declare (ignore relative filename))
887      (let ((new-base
888             (make-pathname :defaults root
889                            :directory `(:absolute ,@path))))
890        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
891
892#+scl
893(defun* directorize-pathname-host-device (pathname)
894  (let ((scheme (ext:pathname-scheme pathname))
895        (host (pathname-host pathname))
896        (port (ext:pathname-port pathname))
897        (directory (pathname-directory pathname)))
898    (if (or (ununspecific port)
899            (and (ununspecific host) (plusp (length host)))
900            (ununspecific scheme))
901        (let ((prefix ""))
902          (when (ununspecific port)
903            (setf prefix (format nil ":~D" port)))
904          (when (and (ununspecific host) (plusp (length host)))
905            (setf prefix (strcat host prefix)))
906          (setf prefix (strcat ":" prefix))
907          (when (ununspecific scheme)
908            (setf prefix (strcat scheme prefix)))
909          (assert (and directory (eq (first directory) :absolute)))
910          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
911                         :defaults pathname)))
912    pathname))
913
914;;;; -------------------------------------------------------------------------
915;;;; ASDF Interface, in terms of generic functions.
916(defgeneric* find-system (system &optional error-p))
917(defgeneric* perform-with-restarts (operation component))
918(defgeneric* perform (operation component))
919(defgeneric* operation-done-p (operation component))
920(defgeneric* mark-operation-done (operation component))
921(defgeneric* explain (operation component))
922(defgeneric* output-files (operation component))
923(defgeneric* input-files (operation component))
924(defgeneric* component-operation-time (operation component))
925(defgeneric* operation-description (operation component)
926  (:documentation "returns a phrase that describes performing this operation
927on this component, e.g. \"loading /a/b/c\".
928You can put together sentences using this phrase."))
929
930(defgeneric* system-source-file (system)
931  (:documentation "Return the source file in which system is defined."))
932
933(defgeneric* component-system (component)
934  (:documentation "Find the top-level system containing COMPONENT"))
935
936(defgeneric* component-pathname (component)
937  (:documentation "Extracts the pathname applicable for a particular component."))
938
939(defgeneric* component-relative-pathname (component)
940  (:documentation "Returns a pathname for the component argument intended to be
941interpreted relative to the pathname of that component's parent.
942Despite the function's name, the return value may be an absolute
943pathname, because an absolute pathname may be interpreted relative to
944another pathname in a degenerate way."))
945
946(defgeneric* component-property (component property))
947
948(defgeneric* (setf component-property) (new-value component property))
949
950(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
951  (defgeneric* (setf module-components-by-name) (new-value module)))
952
953(defgeneric* version-satisfies (component version))
954
955(defgeneric* find-component (base path)
956  (:documentation "Finds the component with PATH starting from BASE module;
957if BASE is nil, then the component is assumed to be a system."))
958
959(defgeneric* source-file-type (component system))
960
961(defgeneric* operation-ancestor (operation)
962  (:documentation
963   "Recursively chase the operation's parent pointer until we get to
964the head of the tree"))
965
966(defgeneric* component-visited-p (operation component)
967  (:documentation "Returns the value stored by a call to
968VISIT-COMPONENT, if that has been called, otherwise NIL.
969This value stored will be a cons cell, the first element
970of which is a computed key, so not interesting.  The
971CDR wil be the DATA value stored by VISIT-COMPONENT; recover
972it as (cdr (component-visited-p op c)).
973  In the current form of ASDF, the DATA value retrieved is
974effectively a boolean, indicating whether some operations are
975to be performed in order to do OPERATION X COMPONENT.  If the
976data value is NIL, the combination had been explored, but no
977operations needed to be performed."))
978
979(defgeneric* visit-component (operation component data)
980  (:documentation "Record DATA as being associated with OPERATION
981and COMPONENT.  This is a side-effecting function:  the association
982will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
983OPERATION\).
984  No evidence that DATA is ever interesting, beyond just being
985non-NIL.  Using the data field is probably very risky; if there is
986already a record for OPERATION X COMPONENT, DATA will be quietly
987discarded instead of recorded.
988  Starting with 2.006, TRAVERSE will store an integer in data,
989so that nodes can be sorted in decreasing order of traversal."))
990
991
992(defgeneric* (setf visiting-component) (new-value operation component))
993
994(defgeneric* component-visiting-p (operation component))
995
996(defgeneric* component-depends-on (operation component)
997  (:documentation
998   "Returns a list of dependencies needed by the component to perform
999    the operation.  A dependency has one of the following forms:
1000
1001      (<operation> <component>*), where <operation> is a class
1002        designator and each <component> is a component
1003        designator, which means that the component depends on
1004        <operation> having been performed on each <component>; or
1005
1006      (FEATURE <feature>), which means that the component depends
1007        on <feature>'s presence in *FEATURES*.
1008
1009    Methods specialized on subclasses of existing component types
1010    should usually append the results of CALL-NEXT-METHOD to the
1011    list."))
1012
1013(defgeneric* component-self-dependencies (operation component))
1014
1015(defgeneric* traverse (operation component)
1016  (:documentation
1017"Generate and return a plan for performing OPERATION on COMPONENT.
1018
1019The plan returned is a list of dotted-pairs. Each pair is the CONS
1020of ASDF operation object and a COMPONENT object. The pairs will be
1021processed in order by OPERATE."))
1022
1023
1024;;;; -------------------------------------------------------------------------
1025;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
1026(when *upgraded-p*
1027   (when (find-class 'module nil)
1028     (eval
1029      '(defmethod update-instance-for-redefined-class :after
1030           ((m module) added deleted plist &key)
1031         (declare (ignorable deleted plist))
1032         (when *asdf-verbose*
1033           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
1034                         m (asdf-version)))
1035         (when (member 'components-by-name added)
1036           (compute-module-components-by-name m))
1037         (when (typep m 'system)
1038           (when (member 'source-file added)
1039             (%set-system-source-file
1040              (probe-asd (component-name m) (component-pathname m)) m)
1041             (when (equal (component-name m) "asdf")
1042               (setf (component-version m) *asdf-version*))))))))
1043
1044;;;; -------------------------------------------------------------------------
1045;;;; Classes, Conditions
1046
1047(define-condition system-definition-error (error) ()
1048  ;; [this use of :report should be redundant, but unfortunately it's not.
1049  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
1050  ;; over print-object; this is always conditions::%print-condition for
1051  ;; condition objects, which in turn does inheritance of :report options at
1052  ;; run-time.  fortunately, inheritance means we only need this kludge here in
1053  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
1054  #+cmu (:report print-object))
1055
1056(define-condition formatted-system-definition-error (system-definition-error)
1057  ((format-control :initarg :format-control :reader format-control)
1058   (format-arguments :initarg :format-arguments :reader format-arguments))
1059  (:report (lambda (c s)
1060               (apply 'format s (format-control c) (format-arguments c)))))
1061
1062(define-condition load-system-definition-error (system-definition-error)
1063  ((name :initarg :name :reader error-name)
1064   (pathname :initarg :pathname :reader error-pathname)
1065   (condition :initarg :condition :reader error-condition))
1066  (:report (lambda (c s)
1067             (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
1068                     (error-name c) (error-pathname c) (error-condition c)))))
1069
1070(define-condition circular-dependency (system-definition-error)
1071  ((components :initarg :components :reader circular-dependency-components))
1072  (:report (lambda (c s)
1073             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
1074                     (circular-dependency-components c)))))
1075
1076(define-condition duplicate-names (system-definition-error)
1077  ((name :initarg :name :reader duplicate-names-name))
1078  (:report (lambda (c s)
1079             (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
1080                     (duplicate-names-name c)))))
1081
1082(define-condition missing-component (system-definition-error)
1083  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
1084   (parent :initform nil :reader missing-parent :initarg :parent)))
1085
1086(define-condition missing-component-of-version (missing-component)
1087  ((version :initform nil :reader missing-version :initarg :version)))
1088
1089(define-condition missing-dependency (missing-component)
1090  ((required-by :initarg :required-by :reader missing-required-by)))
1091
1092(define-condition missing-dependency-of-version (missing-dependency
1093                                                 missing-component-of-version)
1094  ())
1095
1096(define-condition operation-error (error)
1097  ((component :reader error-component :initarg :component)
1098   (operation :reader error-operation :initarg :operation))
1099  (:report (lambda (c s)
1100               (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
1101                       (error-operation c) (error-component c)))))
1102(define-condition compile-error (operation-error) ())
1103(define-condition compile-failed (compile-error) ())
1104(define-condition compile-warned (compile-error) ())
1105
1106(define-condition invalid-configuration ()
1107  ((form :reader condition-form :initarg :form)
1108   (location :reader condition-location :initarg :location)
1109   (format :reader condition-format :initarg :format)
1110   (arguments :reader condition-arguments :initarg :arguments :initform nil))
1111  (:report (lambda (c s)
1112               (format s (compatfmt "~@<~? (will be skipped)~@:>")
1113                       (condition-format c)
1114                       (list* (condition-form c) (condition-location c)
1115                              (condition-arguments c))))))
1116(define-condition invalid-source-registry (invalid-configuration warning)
1117  ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
1118(define-condition invalid-output-translation (invalid-configuration warning)
1119  ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
1120
1121(defclass component ()
1122  ((name :accessor component-name :initarg :name :type string :documentation
1123         "Component name: designator for a string composed of portable pathname characters")
1124   ;; We might want to constrain version with
1125   ;; :type (and string (satisfies parse-version))
1126   ;; but we cannot until we fix all systems that don't use it correctly!
1127   (version :accessor component-version :initarg :version)
1128   (description :accessor component-description :initarg :description)
1129   (long-description :accessor component-long-description :initarg :long-description)
1130   ;; This one below is used by POIU - http://www.cliki.net/poiu
1131   ;; a parallelizing extension of ASDF that compiles in multiple parallel
1132   ;; slave processes (forked on demand) and loads in the master process.
1133   ;; Maybe in the future ASDF may use it internally instead of in-order-to.
1134   (load-dependencies :accessor component-load-dependencies :initform nil)
1135   ;; In the ASDF object model, dependencies exist between *actions*
1136   ;; (an action is a pair of operation and component). They are represented
1137   ;; alists of operations to dependencies (other actions) in each component.
1138   ;; There are two kinds of dependencies, each stored in its own slot:
1139   ;; in-order-to and do-first dependencies. These two kinds are related to
1140   ;; the fact that some actions modify the filesystem,
1141   ;; whereas other actions modify the current image, and
1142   ;; this implies a difference in how to interpret timestamps.
1143   ;; in-order-to dependencies will trigger re-performing the action
1144   ;; when the timestamp of some dependency
1145   ;; makes the timestamp of current action out-of-date;
1146   ;; do-first dependencies do not trigger such re-performing.
1147   ;; Therefore, a FASL must be recompiled if it is obsoleted
1148   ;; by any of its FASL dependencies (in-order-to); but
1149   ;; it needn't be recompiled just because one of these dependencies
1150   ;; hasn't yet been loaded in the current image (do-first).
1151   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
1152   ;; See our ASDF 2 paper for more complete explanations.
1153   (in-order-to :initform nil :initarg :in-order-to
1154                :accessor component-in-order-to)
1155   (do-first :initform nil :initarg :do-first
1156             :accessor component-do-first)
1157   ;; methods defined using the "inline" style inside a defsystem form:
1158   ;; need to store them somewhere so we can delete them when the system
1159   ;; is re-evaluated
1160   (inline-methods :accessor component-inline-methods :initform nil)
1161   (parent :initarg :parent :initform nil :reader component-parent)
1162   ;; no direct accessor for pathname, we do this as a method to allow
1163   ;; it to default in funky ways if not supplied
1164   (relative-pathname :initarg :pathname)
1165   ;; the absolute-pathname is computed based on relative-pathname...
1166   (absolute-pathname)
1167   (operation-times :initform (make-hash-table)
1168                    :accessor component-operation-times)
1169   (around-compile :initarg :around-compile)
1170   ;; XXX we should provide some atomic interface for updating the
1171   ;; component properties
1172   (properties :accessor component-properties :initarg :properties
1173               :initform nil)))
1174
1175(defun* component-find-path (component)
1176  (reverse
1177   (loop :for c = component :then (component-parent c)
1178     :while c :collect (component-name c))))
1179
1180(defmethod print-object ((c component) stream)
1181  (print-unreadable-object (c stream :type t :identity nil)
1182    (format stream "~{~S~^ ~}" (component-find-path c))))
1183
1184
1185;;;; methods: conditions
1186
1187(defmethod print-object ((c missing-dependency) s)
1188  (format s (compatfmt "~@<~A, required by ~A~@:>")
1189          (call-next-method c nil) (missing-required-by c)))
1190
1191(defun* sysdef-error (format &rest arguments)
1192  (error 'formatted-system-definition-error :format-control
1193         format :format-arguments arguments))
1194
1195;;;; methods: components
1196
1197(defmethod print-object ((c missing-component) s)
1198  (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
1199          (missing-requires c)
1200          (when (missing-parent c)
1201            (coerce-name (missing-parent c)))))
1202
1203(defmethod print-object ((c missing-component-of-version) s)
1204  (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
1205          (missing-requires c)
1206          (missing-version c)
1207          (when (missing-parent c)
1208            (coerce-name (missing-parent c)))))
1209
1210(defmethod component-system ((component component))
1211  (aif (component-parent component)
1212       (component-system it)
1213       component))
1214
1215(defvar *default-component-class* 'cl-source-file)
1216
1217(defun* compute-module-components-by-name (module)
1218  (let ((hash (make-hash-table :test 'equal)))
1219    (setf (module-components-by-name module) hash)
1220    (loop :for c :in (module-components module)
1221      :for name = (component-name c)
1222      :for previous = (gethash name (module-components-by-name module))
1223      :do
1224      (when previous
1225        (error 'duplicate-names :name name))
1226      :do (setf (gethash name (module-components-by-name module)) c))
1227    hash))
1228
1229(defclass module (component)
1230  ((components
1231    :initform nil
1232    :initarg :components
1233    :accessor module-components)
1234   (components-by-name
1235    :accessor module-components-by-name)
1236   ;; What to do if we can't satisfy a dependency of one of this module's
1237   ;; components.  This allows a limited form of conditional processing.
1238   (if-component-dep-fails
1239    :initform :fail
1240    :initarg :if-component-dep-fails
1241    :accessor module-if-component-dep-fails)
1242   (default-component-class
1243    :initform *default-component-class*
1244    :initarg :default-component-class
1245    :accessor module-default-component-class)))
1246
1247(defun* component-parent-pathname (component)
1248  ;; No default anymore (in particular, no *default-pathname-defaults*).
1249  ;; If you force component to have a NULL pathname, you better arrange
1250  ;; for any of its children to explicitly provide a proper absolute pathname
1251  ;; wherever a pathname is actually wanted.
1252  (let ((parent (component-parent component)))
1253    (when parent
1254      (component-pathname parent))))
1255
1256(defmethod component-pathname ((component component))
1257  (if (slot-boundp component 'absolute-pathname)
1258      (slot-value component 'absolute-pathname)
1259      (let ((pathname
1260             (merge-pathnames*
1261              (component-relative-pathname component)
1262              (pathname-directory-pathname (component-parent-pathname component)))))
1263        (unless (or (null pathname) (absolute-pathname-p pathname))
1264          (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
1265                 pathname (component-find-path component)))
1266        (setf (slot-value component 'absolute-pathname) pathname)
1267        pathname)))
1268
1269(defmethod component-property ((c component) property)
1270  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
1271
1272(defmethod (setf component-property) (new-value (c component) property)
1273  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
1274    (if a
1275        (setf (cdr a) new-value)
1276        (setf (slot-value c 'properties)
1277              (acons property new-value (slot-value c 'properties)))))
1278  new-value)
1279
1280(defclass proto-system () ; slots to keep when resetting a system
1281  ;; To preserve identity for all objects, we'd need keep the components slots
1282  ;; but also to modify parse-component-form to reset the recycled objects.
1283  ((name) #|(components) (components-by-names)|#))
1284
1285(defclass system (module proto-system)
1286  (;; description and long-description are now available for all component's,
1287   ;; but now also inherited from component, but we add the legacy accessor
1288   (description :accessor system-description :initarg :description)
1289   (long-description :accessor system-long-description :initarg :long-description)
1290   (author :accessor system-author :initarg :author)
1291   (maintainer :accessor system-maintainer :initarg :maintainer)
1292   (licence :accessor system-licence :initarg :licence
1293            :accessor system-license :initarg :license)
1294   (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
1295                :writer %set-system-source-file)
1296   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
1297
1298;;;; -------------------------------------------------------------------------
1299;;;; version-satisfies
1300
1301(defmethod version-satisfies ((c component) version)
1302  (unless (and version (slot-boundp c 'version))
1303    (when version
1304      (warn "Requested version ~S but component ~S has no version" version c))
1305    (return-from version-satisfies t))
1306  (version-satisfies (component-version c) version))
1307
1308(defun* asdf-version ()
1309  "Exported interface to the version of ASDF currently installed. A string.
1310You can compare this string with e.g.:
1311(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
1312  *asdf-version*)
1313
1314(defun* parse-version (string &optional on-error)
1315  "Parse a version string as a series of natural integers separated by dots.
1316Return a (non-null) list of integers if the string is valid, NIL otherwise.
1317If on-error is error, warn, or designates a function of compatible signature,
1318the function is called with an explanation of what is wrong with the argument.
1319NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
1320  (and
1321   (or (stringp string)
1322       (when on-error
1323         (funcall on-error "~S: ~S is not a string"
1324                  'parse-version string)) nil)
1325   (or (loop :for prev = nil :then c :for c :across string
1326         :always (or (digit-char-p c)
1327                     (and (eql c #\.) prev (not (eql prev #\.))))
1328         :finally (return (and c (digit-char-p c))))
1329       (when on-error
1330         (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
1331                  'parse-version string)) nil)
1332   (mapcar #'parse-integer (split-string string :separator "."))))
1333
1334(defmethod version-satisfies ((cver string) version)
1335  (let ((x (parse-version cver 'warn))
1336        (y (parse-version version 'warn)))
1337    (labels ((bigger (x y)
1338               (cond ((not y) t)
1339                     ((not x) nil)
1340                     ((> (car x) (car y)) t)
1341                     ((= (car x) (car y))
1342                      (bigger (cdr x) (cdr y))))))
1343      (and x y (= (car x) (car y))
1344           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
1345
1346;;;; -----------------------------------------------------------------
1347;;;; Windows shortcut support.  Based on:
1348;;;;
1349;;;; Jesse Hager: The Windows Shortcut File Format.
1350;;;; http://www.wotsit.org/list.asp?fc=13
1351
1352#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
1353(progn
1354(defparameter *link-initial-dword* 76)
1355(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1356
1357(defun* read-null-terminated-string (s)
1358  (with-output-to-string (out)
1359    (loop :for code = (read-byte s)
1360      :until (zerop code)
1361      :do (write-char (code-char code) out))))
1362
1363(defun* read-little-endian (s &optional (bytes 4))
1364  (loop :for i :from 0 :below bytes
1365    :sum (ash (read-byte s) (* 8 i))))
1366
1367(defun* parse-file-location-info (s)
1368  (let ((start (file-position s))
1369        (total-length (read-little-endian s))
1370        (end-of-header (read-little-endian s))
1371        (fli-flags (read-little-endian s))
1372        (local-volume-offset (read-little-endian s))
1373        (local-offset (read-little-endian s))
1374        (network-volume-offset (read-little-endian s))
1375        (remaining-offset (read-little-endian s)))
1376    (declare (ignore total-length end-of-header local-volume-offset))
1377    (unless (zerop fli-flags)
1378      (cond
1379        ((logbitp 0 fli-flags)
1380          (file-position s (+ start local-offset)))
1381        ((logbitp 1 fli-flags)
1382          (file-position s (+ start
1383                              network-volume-offset
1384                              #x14))))
1385      (strcat (read-null-terminated-string s)
1386              (progn
1387                (file-position s (+ start remaining-offset))
1388                (read-null-terminated-string s))))))
1389
1390(defun* parse-windows-shortcut (pathname)
1391  (with-open-file (s pathname :element-type '(unsigned-byte 8))
1392    (handler-case
1393        (when (and (= (read-little-endian s) *link-initial-dword*)
1394                   (let ((header (make-array (length *link-guid*))))
1395                     (read-sequence header s)
1396                     (equalp header *link-guid*)))
1397          (let ((flags (read-little-endian s)))
1398            (file-position s 76)        ;skip rest of header
1399            (when (logbitp 0 flags)
1400              ;; skip shell item id list
1401              (let ((length (read-little-endian s 2)))
1402                (file-position s (+ length (file-position s)))))
1403            (cond
1404              ((logbitp 1 flags)
1405                (parse-file-location-info s))
1406              (t
1407                (when (logbitp 2 flags)
1408                  ;; skip description string
1409                  (let ((length (read-little-endian s 2)))
1410                    (file-position s (+ length (file-position s)))))
1411                (when (logbitp 3 flags)
1412                  ;; finally, our pathname
1413                  (let* ((length (read-little-endian s 2))
1414                         (buffer (make-array length)))
1415                    (read-sequence buffer s)
1416                    (map 'string #'code-char buffer)))))))
1417      (end-of-file ()
1418        nil)))))
1419
1420;;;; -------------------------------------------------------------------------
1421;;;; Finding systems
1422
1423(defun* make-defined-systems-table ()
1424  (make-hash-table :test 'equal))
1425
1426(defvar *defined-systems* (make-defined-systems-table)
1427  "This is a hash table whose keys are strings, being the
1428names of the systems, and whose values are pairs, the first
1429element of which is a universal-time indicating when the
1430system definition was last updated, and the second element
1431of which is a system object.")
1432
1433(defun* coerce-name (name)
1434  (typecase name
1435    (component (component-name name))
1436    (symbol (string-downcase (symbol-name name)))
1437    (string name)
1438    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
1439
1440(defun* system-registered-p (name)
1441  (gethash (coerce-name name) *defined-systems*))
1442
1443(defun* register-system (system)
1444  (check-type system system)
1445  (let ((name (component-name system)))
1446    (check-type name string)
1447    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
1448    (unless (eq system (cdr (gethash name *defined-systems*)))
1449      (setf (gethash name *defined-systems*)
1450            (cons (get-universal-time) system)))))
1451
1452(defun* clear-system (name)
1453  "Clear the entry for a system in the database of systems previously loaded.
1454Note that this does NOT in any way cause the code of the system to be unloaded."
1455  ;; There is no "unload" operation in Common Lisp, and
1456  ;; a general such operation cannot be portably written,
1457  ;; considering how much CL relies on side-effects to global data structures.
1458  (remhash (coerce-name name) *defined-systems*))
1459
1460(defun* map-systems (fn)
1461  "Apply FN to each defined system.
1462
1463FN should be a function of one argument. It will be
1464called with an object of type asdf:system."
1465  (maphash #'(lambda (_ datum)
1466               (declare (ignore _))
1467               (destructuring-bind (_ . def) datum
1468                 (declare (ignore _))
1469                 (funcall fn def)))
1470           *defined-systems*))
1471
1472;;; for the sake of keeping things reasonably neat, we adopt a
1473;;; convention that functions in this list are prefixed SYSDEF-
1474
1475(defvar *system-definition-search-functions* '())
1476
1477(setf *system-definition-search-functions*
1478      (append
1479       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
1480       (remove 'contrib-sysdef-search *system-definition-search-functions*)
1481       ;; Tuck our defaults at the end of the list if they were absent.
1482       ;; This is imperfect, in case they were removed on purpose,
1483       ;; but then it will be the responsibility of whoever does that
1484       ;; to upgrade asdf before he does such a thing rather than after.
1485       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
1486                  '(sysdef-central-registry-search
1487                    sysdef-source-registry-search
1488                    sysdef-find-asdf))))
1489
1490(defun* search-for-system-definition (system)
1491  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
1492        (cons 'find-system-if-being-defined
1493              *system-definition-search-functions*)))
1494
1495(defvar *central-registry* nil
1496"A list of 'system directory designators' ASDF uses to find systems.
1497
1498A 'system directory designator' is a pathname or an expression
1499which evaluates to a pathname. For example:
1500
1501    (setf asdf:*central-registry*
1502          (list '*default-pathname-defaults*
1503                #p\"/home/me/cl/systems/\"
1504                #p\"/usr/share/common-lisp/systems/\"))
1505
1506This is for backward compatibilily.
1507Going forward, we recommend new users should be using the source-registry.
1508")
1509
1510(defun* featurep (x &optional (features *features*))
1511  (cond
1512    ((atom x)
1513     (and (member x features) t))
1514    ((eq :not (car x))
1515     (assert (null (cddr x)))
1516     (not (featurep (cadr x) features)))
1517    ((eq :or (car x))
1518     (some #'(lambda (x) (featurep x features)) (cdr x)))
1519    ((eq :and (car x))
1520     (every #'(lambda (x) (featurep x features)) (cdr x)))
1521    (t
1522     (error "Malformed feature specification ~S" x))))
1523
1524(defun* os-unix-p ()
1525  (featurep '(:or :unix :cygwin :darwin)))
1526
1527(defun* os-windows-p ()
1528  (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
1529
1530(defun* probe-asd (name defaults)
1531  (block nil
1532    (when (directory-pathname-p defaults)
1533      (let ((file (make-pathname
1534                   :defaults defaults :name name
1535                   :version :newest :case :local :type "asd")))
1536        (when (probe-file* file)
1537          (return file)))
1538      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
1539      (when (os-windows-p)
1540        (let ((shortcut
1541               (make-pathname
1542                :defaults defaults :version :newest :case :local
1543                :name (strcat name ".asd")
1544                :type "lnk")))
1545          (when (probe-file* shortcut)
1546            (let ((target (parse-windows-shortcut shortcut)))
1547              (when target
1548                (return (pathname target))))))))))
1549
1550(defun* sysdef-central-registry-search (system)
1551  (let ((name (coerce-name system))
1552        (to-remove nil)
1553        (to-replace nil))
1554    (block nil
1555      (unwind-protect
1556           (dolist (dir *central-registry*)
1557             (let ((defaults (eval dir)))
1558               (when defaults
1559                 (cond ((directory-pathname-p defaults)
1560                        (let ((file (probe-asd name defaults)))
1561                          (when file
1562                            (return file))))
1563                       (t
1564                        (restart-case
1565                            (let* ((*print-circle* nil)
1566                                   (message
1567                                    (format nil
1568                                            (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
1569                                            system dir defaults)))
1570                              (error message))
1571                          (remove-entry-from-registry ()
1572                            :report "Remove entry from *central-registry* and continue"
1573                            (push dir to-remove))
1574                          (coerce-entry-to-directory ()
1575                            :report (lambda (s)
1576                                      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
1577                                              (ensure-directory-pathname defaults) dir))
1578                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
1579        ;; cleanup
1580        (dolist (dir to-remove)
1581          (setf *central-registry* (remove dir *central-registry*)))
1582        (dolist (pair to-replace)
1583          (let* ((current (car pair))
1584                 (new (cdr pair))
1585                 (position (position current *central-registry*)))
1586            (setf *central-registry*
1587                  (append (subseq *central-registry* 0 position)
1588                          (list new)
1589                          (subseq *central-registry* (1+ position))))))))))
1590
1591(defun* make-temporary-package ()
1592  (flet ((try (counter)
1593           (ignore-errors
1594             (make-package (format nil "~A~D" :asdf counter)
1595                           :use '(:cl :asdf)))))
1596    (do* ((counter 0 (+ counter 1))
1597          (package (try counter) (try counter)))
1598         (package package))))
1599
1600(defun* safe-file-write-date (pathname)
1601  ;; If FILE-WRITE-DATE returns NIL, it's possible that
1602  ;; the user or some other agent has deleted an input file.
1603  ;; Also, generated files will not exist at the time planning is done
1604  ;; and calls operation-done-p which calls safe-file-write-date.
1605  ;; So it is very possible that we can't get a valid file-write-date,
1606  ;; and we can survive and we will continue the planning
1607  ;; as if the file were very old.
1608  ;; (or should we treat the case in a different, special way?)
1609  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
1610      (progn
1611        (when (and pathname *asdf-verbose*)
1612          (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
1613                pathname))
1614        0)))
1615
1616(defmethod find-system ((name null) &optional (error-p t))
1617  (declare (ignorable name))
1618  (when error-p
1619    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
1620
1621(defmethod find-system (name &optional (error-p t))
1622  (find-system (coerce-name name) error-p))
1623
1624(defvar *systems-being-defined* nil
1625  "A hash-table of systems currently being defined keyed by name, or NIL")
1626
1627(defun* find-system-if-being-defined (name)
1628  (when *systems-being-defined*
1629    (gethash (coerce-name name) *systems-being-defined*)))
1630
1631(defun* call-with-system-definitions (thunk)
1632  (if *systems-being-defined*
1633      (funcall thunk)
1634      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
1635        (funcall thunk))))
1636
1637(defmacro with-system-definitions ((&optional) &body body)
1638  `(call-with-system-definitions #'(lambda () ,@body)))
1639
1640(defun* load-sysdef (name pathname)
1641  ;; Tries to load system definition with canonical NAME from PATHNAME.
1642  (with-system-definitions ()
1643    (let ((package (make-temporary-package)))
1644      (unwind-protect
1645           (handler-bind
1646               ((error #'(lambda (condition)
1647                           (error 'load-system-definition-error
1648                                  :name name :pathname pathname
1649                                  :condition condition))))
1650             (let ((*package* package)
1651                   (*default-pathname-defaults*
1652                    (pathname-directory-pathname pathname)))
1653               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
1654                             pathname package)
1655               (load pathname)))
1656        (delete-package package)))))
1657
1658(defun* locate-system (name)
1659  "Given a system NAME designator, try to locate where to load the system from.
1660Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
1661FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
1662FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
1663PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
1664PREVIOUS when not null is a previously loaded SYSTEM object of same name.
1665PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
1666  (let* ((name (coerce-name name))
1667         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
1668         (previous (cdr in-memory))
1669         (previous (and (typep previous 'system) previous))
1670         (previous-time (car in-memory))
1671           (found (search-for-system-definition name))
1672         (found-system (and (typep found 'system) found))
1673         (pathname (or (and (typep found '(or pathname string)) (pathname found))
1674                       (and found-system (system-source-file found-system))
1675                       (and previous (system-source-file previous))))
1676         (foundp (and (or found-system pathname previous) t)))
1677    (check-type found (or null pathname system))
1678    (when foundp
1679      (setf pathname (resolve-symlinks* pathname))
1680      (when (and pathname (not (absolute-pathname-p pathname)))
1681        (setf pathname (ensure-pathname-absolute pathname))
1682        (when found-system
1683          (%set-system-source-file pathname found-system)))
1684      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
1685                                             (system-source-file previous) pathname)))
1686        (%set-system-source-file pathname previous)
1687        (setf previous-time nil))
1688      (values foundp found-system pathname previous previous-time))))
1689
1690(defmethod find-system ((name string) &optional (error-p t))
1691  (with-system-definitions ()
1692    (loop
1693      (restart-case
1694          (multiple-value-bind (foundp found-system pathname previous previous-time)
1695              (locate-system name)
1696            (declare (ignore foundp))
1697            (when (and found-system (not previous))
1698              (register-system found-system))
1699            (when (and pathname
1700                       (or (not previous-time)
1701                           ;; don't reload if it's already been loaded,
1702                           ;; or its filestamp is in the future which means some clock is skewed
1703                           ;; and trying to load might cause an infinite loop.
1704                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
1705              (load-sysdef name pathname))
1706            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
1707              (return
1708                (cond
1709                  (in-memory
1710                   (when pathname
1711                     (setf (car in-memory) (safe-file-write-date pathname)))
1712                   (cdr in-memory))
1713                  (error-p
1714                   (error 'missing-component :requires name))))))
1715        (reinitialize-source-registry-and-retry ()
1716          :report (lambda (s)
1717                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
1718          (initialize-source-registry))))))
1719
1720(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
1721  (setf fallback (coerce-name fallback)
1722        requested (coerce-name requested))
1723  (when (equal requested fallback)
1724    (let ((registered (cdr (gethash fallback *defined-systems*))))
1725      (or registered
1726          (apply 'make-instance 'system
1727                 :name fallback :source-file source-file keys)))))
1728
1729(defun* sysdef-find-asdf (name)
1730  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
1731  (find-system-fallback name "asdf" :version *asdf-version*))
1732
1733
1734;;;; -------------------------------------------------------------------------
1735;;;; Finding components
1736
1737(defmethod find-component ((base string) path)
1738  (let ((s (find-system base nil)))
1739    (and s (find-component s path))))
1740
1741(defmethod find-component ((base symbol) path)
1742  (cond
1743    (base (find-component (coerce-name base) path))
1744    (path (find-component path nil))
1745    (t    nil)))
1746
1747(defmethod find-component ((base cons) path)
1748  (find-component (car base) (cons (cdr base) path)))
1749
1750(defmethod find-component ((module module) (name string))
1751  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
1752    (compute-module-components-by-name module))
1753  (values (gethash name (module-components-by-name module))))
1754
1755(defmethod find-component ((component component) (name symbol))
1756  (if name
1757      (find-component component (coerce-name name))
1758      component))
1759
1760(defmethod find-component ((module module) (name cons))
1761  (find-component (find-component module (car name)) (cdr name)))
1762
1763
1764;;; component subclasses
1765
1766(defclass source-file (component)
1767  ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
1768
1769(defclass cl-source-file (source-file)
1770  ((type :initform "lisp")))
1771(defclass cl-source-file.cl (cl-source-file)
1772  ((type :initform "cl")))
1773(defclass cl-source-file.lsp (cl-source-file)
1774  ((type :initform "lsp")))
1775(defclass c-source-file (source-file)
1776  ((type :initform "c")))
1777(defclass java-source-file (source-file)
1778  ((type :initform "java")))
1779(defclass static-file (source-file) ())
1780(defclass doc-file (static-file) ())
1781(defclass html-file (doc-file)
1782  ((type :initform "html")))
1783
1784(defmethod source-file-type ((component module) (s module))
1785  (declare (ignorable component s))
1786  :directory)
1787(defmethod source-file-type ((component source-file) (s module))
1788  (declare (ignorable s))
1789  (source-file-explicit-type component))
1790
1791(defun* coerce-pathname (name &key type defaults)
1792  "coerce NAME into a PATHNAME.
1793When given a string, portably decompose it into a relative pathname:
1794#\\/ separates subdirectories. The last #\\/-separated string is as follows:
1795if TYPE is NIL, its last #\\. if any separates name and type from from type;
1796if TYPE is a string, it is the type, and the whole string is the name;
1797if TYPE is :DIRECTORY, the string is a directory component;
1798if the string is empty, it's a directory.
1799Any directory named .. is read as :BACK.
1800Host, device and version components are taken from DEFAULTS."
1801  ;; The defaults are required notably because they provide the default host
1802  ;; to the below make-pathname, which may crucially matter to people using
1803  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
1804  ;; NOTE that the host and device slots will be taken from the defaults,
1805  ;; but that should only matter if you later merge relative pathnames with
1806  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
1807  (etypecase name
1808    ((or null pathname)
1809     name)
1810    (symbol
1811     (coerce-pathname (string-downcase name) :type type :defaults defaults))
1812    (string
1813     (multiple-value-bind (relative path filename)
1814         (component-name-to-pathname-components name :force-directory (eq type :directory)
1815                                                :force-relative t)
1816       (multiple-value-bind (name type)
1817           (cond
1818             ((or (eq type :directory) (null filename))
1819              (values nil nil))
1820             (type
1821              (values filename type))
1822             (t
1823              (split-name-type filename)))
1824         (apply 'make-pathname :directory (cons relative path) :name name :type type
1825                (when defaults `(:defaults ,defaults))))))))
1826
1827(defun* merge-component-name-type (name &key type defaults)
1828  ;; For backwards compatibility only, for people using internals.
1829  ;; Will be removed in a future release, e.g. 2.016.
1830  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
1831  (coerce-pathname name :type type :defaults defaults))
1832
1833(defmethod component-relative-pathname ((component component))
1834  (coerce-pathname
1835   (or (slot-value component 'relative-pathname)
1836       (component-name component))
1837   :type (source-file-type component (component-system component))
1838   :defaults (component-parent-pathname component)))
1839
1840(defun* subpathname (pathname subpath &key type)
1841  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
1842                                  (pathname-directory-pathname pathname))))
1843
1844(defun subpathname* (pathname subpath &key type)
1845  (and pathname
1846       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
1847
1848;;;; -------------------------------------------------------------------------
1849;;;; Operations
1850
1851;;; one of these is instantiated whenever #'operate is called
1852
1853(defclass operation ()
1854  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
1855   ;; T to force the inside of the specified system,
1856   ;;   but not recurse to other systems we depend on.
1857   ;; :ALL (or any other atom) to force all systems
1858   ;;   including other systems we depend on.
1859   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
1860   ;;   to force systems named in a given list
1861   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
1862   (forced :initform nil :initarg :force :accessor operation-forced)
1863   (original-initargs :initform nil :initarg :original-initargs
1864                      :accessor operation-original-initargs)
1865   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
1866   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
1867   (parent :initform nil :initarg :parent :accessor operation-parent)))
1868
1869(defmethod print-object ((o operation) stream)
1870  (print-unreadable-object (o stream :type t :identity t)
1871    (ignore-errors
1872      (prin1 (operation-original-initargs o) stream))))
1873
1874(defmethod shared-initialize :after ((operation operation) slot-names
1875                                     &key force
1876                                     &allow-other-keys)
1877  (declare (ignorable operation slot-names force))
1878  ;; empty method to disable initarg validity checking
1879  (values))
1880
1881(defun* node-for (o c)
1882  (cons (class-name (class-of o)) c))
1883
1884(defmethod operation-ancestor ((operation operation))
1885  (aif (operation-parent operation)
1886       (operation-ancestor it)
1887       operation))
1888
1889
1890(defun* make-sub-operation (c o dep-c dep-o)
1891  "C is a component, O is an operation, DEP-C is another
1892component, and DEP-O, confusingly enough, is an operation
1893class specifier, not an operation."
1894  (let* ((args (copy-list (operation-original-initargs o)))
1895         (force-p (getf args :force)))
1896    ;; note explicit comparison with T: any other non-NIL force value
1897    ;; (e.g. :recursive) will pass through
1898    (cond ((and (null (component-parent c))
1899                (null (component-parent dep-c))
1900                (not (eql c dep-c)))
1901           (when (eql force-p t)
1902             (setf (getf args :force) nil))
1903           (apply 'make-instance dep-o
1904                  :parent o
1905                  :original-initargs args args))
1906          ((subtypep (type-of o) dep-o)
1907           o)
1908          (t
1909           (apply 'make-instance dep-o
1910                  :parent o :original-initargs args args)))))
1911
1912
1913(defmethod visit-component ((o operation) (c component) data)
1914  (unless (component-visited-p o c)
1915    (setf (gethash (node-for o c)
1916                   (operation-visited-nodes (operation-ancestor o)))
1917          (cons t data))))
1918
1919(defmethod component-visited-p ((o operation) (c component))
1920  (gethash (node-for o c)
1921           (operation-visited-nodes (operation-ancestor o))))
1922
1923(defmethod (setf visiting-component) (new-value operation component)
1924  ;; MCL complains about unused lexical variables
1925  (declare (ignorable operation component))
1926  new-value)
1927
1928(defmethod (setf visiting-component) (new-value (o operation) (c component))
1929  (let ((node (node-for o c))
1930        (a (operation-ancestor o)))
1931    (if new-value
1932        (setf (gethash node (operation-visiting-nodes a)) t)
1933        (remhash node (operation-visiting-nodes a)))
1934    new-value))
1935
1936(defmethod component-visiting-p ((o operation) (c component))
1937  (let ((node (node-for o c)))
1938    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
1939
1940(defmethod component-depends-on ((op-spec symbol) (c component))
1941  ;; Note: we go from op-spec to operation via make-instance
1942  ;; to allow for specialization through defmethod's, even though
1943  ;; it's a detour in the default case below.
1944  (component-depends-on (make-instance op-spec) c))
1945
1946(defmethod component-depends-on ((o operation) (c component))
1947  (cdr (assoc (type-of o) (component-in-order-to c))))
1948
1949(defmethod component-self-dependencies ((o operation) (c component))
1950  (remove-if-not
1951   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
1952   (component-depends-on o c)))
1953
1954(defmethod input-files ((operation operation) (c component))
1955  (let ((parent (component-parent c))
1956        (self-deps (component-self-dependencies operation c)))
1957    (if self-deps
1958        (mapcan #'(lambda (dep)
1959                    (destructuring-bind (op name) dep
1960                      (output-files (make-instance op)
1961                                    (find-component parent name))))
1962                self-deps)
1963        ;; no previous operations needed?  I guess we work with the
1964        ;; original source file, then
1965        (list (component-pathname c)))))
1966
1967(defmethod input-files ((operation operation) (c module))
1968  (declare (ignorable operation c))
1969  nil)
1970
1971(defmethod component-operation-time (o c)
1972  (gethash (type-of o) (component-operation-times c)))
1973
1974(defmethod operation-done-p ((o operation) (c component))
1975  (let ((out-files (output-files o c))
1976        (in-files (input-files o c))
1977        (op-time (component-operation-time o c)))
1978    (flet ((earliest-out ()
1979             (reduce #'min (mapcar #'safe-file-write-date out-files)))
1980           (latest-in ()
1981             (reduce #'max (mapcar #'safe-file-write-date in-files))))
1982      (cond
1983        ((and (not in-files) (not out-files))
1984         ;; arbitrary decision: an operation that uses nothing to
1985         ;; produce nothing probably isn't doing much.
1986         ;; e.g. operations on systems, modules that have no immediate action,
1987         ;; but are only meaningful through traversed dependencies
1988         t)
1989        ((not out-files)
1990         ;; an operation without output-files is probably meant
1991         ;; for its side-effects in the current image,
1992         ;; assumed to be idem-potent,
1993         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
1994         (and op-time (>= op-time (latest-in))))
1995        ((not in-files)
1996         ;; an operation with output-files and no input-files
1997         ;; is probably meant for its side-effects on the file-system,
1998         ;; assumed to have to be done everytime.
1999         ;; (I don't think there is any such case in ASDF unless extended)
2000         nil)
2001        (t
2002         ;; an operation with both input and output files is assumed
2003         ;; as computing the latter from the former,
2004         ;; assumed to have been done if the latter are all older
2005         ;; than the former.
2006         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
2007         ;; We use >= instead of > to play nice with generated files.
2008         ;; This opens a race condition if an input file is changed
2009         ;; after the output is created but within the same second
2010         ;; of filesystem time; but the same race condition exists
2011         ;; whenever the computation from input to output takes more
2012         ;; than one second of filesystem time (or just crosses the
2013         ;; second). So that's cool.
2014         (and
2015          (every #'probe-file* in-files)
2016          (every #'probe-file* out-files)
2017          (>= (earliest-out) (latest-in))))))))
2018
2019
2020
2021;;; For 1.700 I've done my best to refactor TRAVERSE
2022;;; by splitting it up in a bunch of functions,
2023;;; so as to improve the collection and use-detection algorithm. --fare
2024;;; The protocol is as follows: we pass around operation, dependency,
2025;;; bunch of other stuff, and a force argument. Return a force flag.
2026;;; The returned flag is T if anything has changed that requires a rebuild.
2027;;; The force argument is a list of components that will require a rebuild
2028;;; if the flag is T, at which point whoever returns the flag has to
2029;;; mark them all as forced, and whoever recurses again can use a NIL list
2030;;; as a further argument.
2031
2032(defvar *forcing* nil
2033  "This dynamically-bound variable is used to force operations in
2034recursive calls to traverse.")
2035
2036(defgeneric* do-traverse (operation component collect))
2037
2038(defun* resolve-dependency-name (component name &optional version)
2039  (loop
2040    (restart-case
2041        (return
2042          (let ((comp (find-component (component-parent component) name)))
2043            (unless comp
2044              (error 'missing-dependency
2045                     :required-by component
2046                     :requires name))
2047            (when version
2048              (unless (version-satisfies comp version)
2049                (error 'missing-dependency-of-version
2050                       :required-by component
2051                       :version version
2052                       :requires name)))
2053            comp))
2054      (retry ()
2055        :report (lambda (s)
2056                  (format s "~@<Retry loading ~3i~_~A.~@:>" name))
2057        :test
2058        (lambda (c)
2059          (or (null c)
2060              (and (typep c 'missing-dependency)
2061                   (eq (missing-required-by c) component)
2062                   (equal (missing-requires c) name))))))))
2063
2064(defun* resolve-dependency-spec (component dep-spec)
2065  (cond
2066    ((atom dep-spec)
2067     (resolve-dependency-name component dep-spec))
2068    ;; Structured dependencies --- this parses keywords.
2069    ;; The keywords could conceivably be broken out and cleanly (extensibly)
2070    ;; processed by EQL methods. But for now, here's what we've got.
2071    ((eq :version (first dep-spec))
2072     ;; https://bugs.launchpad.net/asdf/+bug/527788
2073     (resolve-dependency-name component (second dep-spec) (third dep-spec)))
2074    ((eq :feature (first dep-spec))
2075     ;; This particular subform is not documented and
2076     ;; has always been broken in the past.
2077     ;; Therefore no one uses it, and I'm cerroring it out,
2078     ;; after fixing it
2079     ;; See https://bugs.launchpad.net/asdf/+bug/518467
2080     (cerror "Continue nonetheless."
2081             "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
2082     (when (find (second dep-spec) *features* :test 'string-equal)
2083       (resolve-dependency-name component (third dep-spec))))
2084    (t
2085     (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
2086
2087(defun* do-one-dep (op c collect dep-op dep-c)
2088  ;; Collects a partial plan for performing dep-op on dep-c
2089  ;; as dependencies of a larger plan involving op and c.
2090  ;; Returns t if this should force recompilation of those who depend on us.
2091  ;; dep-op is an operation class name (not an operation object),
2092  ;; whereas dep-c is a component object.n
2093  (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
2094
2095(defun* do-dep (op c collect dep-op-spec dep-c-specs)
2096  ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
2097  ;; as dependencies of a larger plan involving op and c.
2098  ;; Returns t if this should force recompilation of those who depend on us.
2099  ;; dep-op-spec is either an operation class name (not an operation object),
2100  ;; or the magic symbol asdf:feature.
2101  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
2102  ;; and the plan will succeed if that keyword is present in *feature*,
2103  ;; or fail if it isn't
2104  ;; (at which point c's :if-component-dep-fails will kick in).
2105  ;; If dep-op-spec is an operation class name,
2106  ;; then dep-c-specs specifies a list of sibling component of c,
2107  ;; as per resolve-dependency-spec, such that operating op on c
2108  ;; depends on operating dep-op-spec on each of them.
2109  (cond ((eq dep-op-spec 'feature)
2110         (if (member (car dep-c-specs) *features*)
2111             nil
2112             (error 'missing-dependency
2113                    :required-by c
2114                    :requires (list :feature (car dep-c-specs)))))
2115        (t
2116         (let ((flag nil))
2117           (dolist (d dep-c-specs)
2118             (when (do-one-dep op c collect dep-op-spec
2119                               (resolve-dependency-spec c d))
2120               (setf flag t)))
2121           flag))))
2122
2123(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
2124
2125(defun* do-collect (collect x)
2126  (funcall collect x))
2127
2128(defmethod do-traverse ((operation operation) (c component) collect)
2129  (let ((*forcing* *forcing*)
2130        (flag nil)) ;; return value: must we rebuild this and its dependencies?
2131    (labels
2132        ((update-flag (x)
2133           (orf flag x))
2134         (dep (op comp)
2135           (update-flag (do-dep operation c collect op comp))))
2136      ;; Have we been visited yet? If so, just process the result.
2137      (aif (component-visited-p operation c)
2138           (progn
2139             (update-flag (cdr it))
2140             (return-from do-traverse flag)))
2141      ;; dependencies
2142      (when (component-visiting-p operation c)
2143        (error 'circular-dependency :components (list c)))
2144      (setf (visiting-component operation c) t)
2145      (unwind-protect
2146           (progn
2147             (let ((f (operation-forced
2148                       (operation-ancestor operation))))
2149               (when (and f (or (not (consp f)) ;; T or :ALL
2150                                (and (typep c 'system) ;; list of names of systems to force
2151                                     (member (component-name c) f
2152                                             :test #'string=))))
2153                 (setf *forcing* t)))
2154             ;; first we check and do all the dependencies for the module.
2155             ;; Operations planned in this loop will show up
2156             ;; in the results, and are consumed below.
2157             (let ((*forcing* nil))
2158               ;; upstream dependencies are never forced to happen just because
2159               ;; the things that depend on them are....
2160               (loop
2161                 :for (required-op . deps) :in (component-depends-on operation c)
2162                 :do (dep required-op deps)))
2163             ;; constituent bits
2164             (let ((module-ops
2165                    (when (typep c 'module)
2166                      (let ((at-least-one nil)
2167                            ;; This is set based on the results of the
2168                            ;; dependencies and whether we are in the
2169                            ;; context of a *forcing* call...
2170                            ;; inter-system dependencies do NOT trigger
2171                            ;; building components
2172                            (*forcing*
2173                             (or *forcing*
2174                                 (and flag (not (typep c 'system)))))
2175                            (error nil))
2176                        (while-collecting (internal-collect)
2177                          (dolist (kid (module-components c))
2178                            (handler-case
2179                                (update-flag
2180                                 (do-traverse operation kid #'internal-collect))
2181                              #-genera
2182                              (missing-dependency (condition)
2183                                (when (eq (module-if-component-dep-fails c)
2184                                          :fail)
2185                                  (error condition))
2186                                (setf error condition))
2187                              (:no-error (c)
2188                                (declare (ignore c))
2189                                (setf at-least-one t))))
2190                          (when (and (eq (module-if-component-dep-fails c)
2191                                         :try-next)
2192                                     (not at-least-one))
2193                            (error error)))))))
2194               (update-flag (or *forcing* (not (operation-done-p operation c))))
2195                 ;; For sub-operations, check whether
2196                 ;; the original ancestor operation was forced,
2197                 ;; or names us amongst an explicit list of things to force...
2198                 ;; except that this check doesn't distinguish
2199                 ;; between all the things with a given name. Sigh.
2200                 ;; BROKEN!
2201               (when flag
2202                 (let ((do-first (cdr (assoc (class-name (class-of operation))
2203                                             (component-do-first c)))))
2204                   (loop :for (required-op . deps) :in do-first
2205                     :do (do-dep operation c collect required-op deps)))
2206                 (do-collect collect (vector module-ops))
2207                 (do-collect collect (cons operation c)))))
2208             (setf (visiting-component operation c) nil)))
2209      (visit-component operation c (when flag (incf *visit-count*)))
2210      flag))
2211
2212(defun* flatten-tree (l)
2213  ;; You collected things into a list.
2214  ;; Most elements are just things to collect again.
2215  ;; A (simple-vector 1) indicate that you should recurse into its contents.
2216  ;; This way, in two passes (rather than N being the depth of the tree),
2217  ;; you can collect things with marginally constant-time append,
2218  ;; achieving linear time collection instead of quadratic time.
2219  (while-collecting (c)
2220    (labels ((r (x)
2221               (if (typep x '(simple-vector 1))
2222                   (r* (svref x 0))
2223                   (c x)))
2224             (r* (l)
2225               (dolist (x l) (r x))))
2226      (r* l))))
2227
2228(defmethod traverse ((operation operation) (c component))
2229  (when (consp (operation-forced operation))
2230    (setf (operation-forced operation)
2231          (mapcar #'coerce-name (operation-forced operation))))
2232  (flatten-tree
2233   (while-collecting (collect)
2234     (let ((*visit-count* 0))
2235       (do-traverse operation c #'collect)))))
2236
2237(defmethod perform ((operation operation) (c source-file))
2238  (sysdef-error
2239   (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
2240   (class-of operation) (class-of c)))
2241
2242(defmethod perform ((operation operation) (c module))
2243  (declare (ignorable operation c))
2244  nil)
2245
2246(defmethod mark-operation-done ((operation operation) (c component))
2247  (setf (gethash (type-of operation) (component-operation-times c))
2248    (reduce #'max
2249            (cons (get-universal-time)
2250                  (mapcar #'safe-file-write-date (input-files operation c))))))
2251
2252(defmethod perform-with-restarts (operation component)
2253  ;; TOO verbose, especially as the default. Add your own :before method
2254  ;; to perform-with-restart or perform if you want that:
2255  #|(when *asdf-verbose* (explain operation component))|#
2256  (perform operation component))
2257
2258(defmethod perform-with-restarts :around (operation component)
2259  (loop
2260    (restart-case
2261        (return (call-next-method))
2262      (retry ()
2263        :report
2264        (lambda (s)
2265          (format s (compatfmt "~@<Retry ~A.~@:>")
2266                  (operation-description operation component))))
2267      (accept ()
2268        :report
2269        (lambda (s)
2270          (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
2271                  (operation-description operation component)))
2272        (mark-operation-done operation component)
2273        (return)))))
2274
2275(defmethod explain ((operation operation) (component component))
2276  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
2277                (operation-description operation component)))
2278
2279(defmethod operation-description (operation component)
2280  (format nil (compatfmt "~@<~A on ~A~@:>")
2281          (class-of operation) component))
2282
2283;;;; -------------------------------------------------------------------------
2284;;;; compile-op
2285
2286(defclass compile-op (operation)
2287  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
2288   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
2289                :initform *compile-file-warnings-behaviour*)
2290   (on-failure :initarg :on-failure :accessor operation-on-failure
2291               :initform *compile-file-failure-behaviour*)
2292   (flags :initarg :flags :accessor compile-op-flags
2293          :initform nil)))
2294
2295(defun* output-file (operation component)
2296  "The unique output file of performing OPERATION on COMPONENT"
2297  (let ((files (output-files operation component)))
2298    (assert (length=n-p files 1))
2299    (first files)))
2300
2301(defun* ensure-all-directories-exist (pathnames)
2302   (loop :for pn :in pathnames
2303     :for pathname = (if (typep pn 'logical-pathname)
2304                         (translate-logical-pathname pn)
2305                         pn)
2306     :do (ensure-directories-exist pathname)))
2307
2308(defmethod perform :before ((operation compile-op) (c source-file))
2309  (ensure-all-directories-exist (asdf:output-files operation c)))
2310
2311(defmethod perform :after ((operation operation) (c component))
2312  (mark-operation-done operation c))
2313
2314(defgeneric* around-compile-hook (component))
2315(defgeneric* call-with-around-compile-hook (component thunk))
2316
2317(defmethod around-compile-hook ((c component))
2318  (cond
2319    ((slot-boundp c 'around-compile)
2320     (slot-value c 'around-compile))
2321    ((component-parent c)
2322     (around-compile-hook (component-parent c)))))
2323
2324(defun ensure-function (fun &key (package :asdf))
2325  (etypecase fun
2326    ((or symbol function) fun)
2327    (cons (eval `(function ,fun)))
2328    (string (eval `(function ,(with-standard-io-syntax
2329                               (let ((*package* (find-package package)))
2330                                 (read-from-string fun))))))))
2331
2332(defmethod call-with-around-compile-hook ((c component) thunk)
2333  (let ((hook (around-compile-hook c)))
2334    (if hook
2335        (funcall (ensure-function hook) thunk)
2336        (funcall thunk))))
2337
2338(defvar *compile-op-compile-file-function* 'compile-file*
2339  "Function used to compile lisp files.")
2340
2341;;; perform is required to check output-files to find out where to put
2342;;; its answers, in case it has been overridden for site policy
2343(defmethod perform ((operation compile-op) (c cl-source-file))
2344  #-:broken-fasl-loader
2345  (let ((source-file (component-pathname c))
2346        ;; on some implementations, there are more than one output-file,
2347        ;; but the first one should always be the primary fasl that gets loaded.
2348        (output-file (first (output-files operation c)))
2349        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
2350        (*compile-file-failure-behaviour* (operation-on-failure operation)))
2351    (multiple-value-bind (output warnings-p failure-p)
2352        (call-with-around-compile-hook
2353         c #'(lambda ()
2354               (apply *compile-op-compile-file-function* source-file
2355                      :output-file output-file (compile-op-flags operation))))
2356      (unless output
2357        (error 'compile-error :component c :operation operation))
2358      (when failure-p
2359        (case (operation-on-failure operation)
2360          (:warn (warn
2361                  (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
2362                  operation c))
2363          (:error (error 'compile-failed :component c :operation operation))
2364          (:ignore nil)))
2365      (when warnings-p
2366        (case (operation-on-warnings operation)
2367          (:warn (warn
2368                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
2369                  operation c))
2370          (:error (error 'compile-warned :component c :operation operation))
2371          (:ignore nil))))))
2372
2373(defmethod output-files ((operation compile-op) (c cl-source-file))
2374  (declare (ignorable operation))
2375  (let ((p (lispize-pathname (component-pathname c))))
2376    #-broken-fasl-loader (list (compile-file-pathname p))
2377    #+broken-fasl-loader (list p)))
2378
2379(defmethod perform ((operation compile-op) (c static-file))
2380  (declare (ignorable operation c))
2381  nil)
2382
2383(defmethod output-files ((operation compile-op) (c static-file))
2384  (declare (ignorable operation c))
2385  nil)
2386
2387(defmethod input-files ((operation compile-op) (c static-file))
2388  (declare (ignorable operation c))
2389  nil)
2390
2391(defmethod operation-description ((operation compile-op) component)
2392  (declare (ignorable operation))
2393  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
2394
2395(defmethod operation-description ((operation compile-op) (component module))
2396  (declare (ignorable operation))
2397  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
2398
2399
2400;;;; -------------------------------------------------------------------------
2401;;;; load-op
2402
2403(defclass basic-load-op (operation) ())
2404
2405(defclass load-op (basic-load-op) ())
2406
2407(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
2408  (loop
2409    (restart-case
2410        (return (call-next-method))
2411      (try-recompiling ()
2412        :report (lambda (s)
2413                  (format s "Recompile ~a and try loading it again"
2414                          (component-name c)))
2415        (perform (make-sub-operation c o c 'compile-op) c)))))
2416
2417(defmethod perform ((o load-op) (c cl-source-file))
2418  (map () #'load (input-files o c)))
2419
2420(defmethod perform ((operation load-op) (c static-file))
2421  (declare (ignorable operation c))
2422  nil)
2423
2424(defmethod operation-done-p ((operation load-op) (c static-file))
2425  (declare (ignorable operation c))
2426  t)
2427
2428(defmethod output-files ((operation operation) (c component))
2429  (declare (ignorable operation c))
2430  nil)
2431
2432(defmethod component-depends-on ((operation load-op) (c component))
2433  (declare (ignorable operation))
2434  (cons (list 'compile-op (component-name c))
2435        (call-next-method)))
2436
2437(defmethod operation-description ((operation load-op) component)
2438  (declare (ignorable operation))
2439  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
2440          component))
2441
2442(defmethod operation-description ((operation load-op) (component cl-source-file))
2443  (declare (ignorable operation))
2444  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
2445          component))
2446
2447(defmethod operation-description ((operation load-op) (component module))
2448  (declare (ignorable operation))
2449  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
2450          component))
2451
2452;;;; -------------------------------------------------------------------------
2453;;;; load-source-op
2454
2455(defclass load-source-op (basic-load-op) ())
2456
2457(defmethod perform ((o load-source-op) (c cl-source-file))
2458  (declare (ignorable o))
2459  (let ((source (component-pathname c)))
2460    (setf (component-property c 'last-loaded-as-source)
2461          (and (call-with-around-compile-hook c #'(lambda () (load source)))
2462               (get-universal-time)))))
2463
2464(defmethod perform ((operation load-source-op) (c static-file))
2465  (declare (ignorable operation c))
2466  nil)
2467
2468(defmethod output-files ((operation load-source-op) (c component))
2469  (declare (ignorable operation c))
2470  nil)
2471
2472;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
2473(defmethod component-depends-on ((o load-source-op) (c component))
2474  (declare (ignorable o))
2475  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
2476    :for (op . co) :in what-would-load-op-do
2477    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
2478
2479(defmethod operation-done-p ((o load-source-op) (c source-file))
2480  (declare (ignorable o))
2481  (if (or (not (component-property c 'last-loaded-as-source))
2482          (> (safe-file-write-date (component-pathname c))
2483             (component-property c 'last-loaded-as-source)))
2484      nil t))
2485
2486(defmethod operation-description ((operation load-source-op) component)
2487  (declare (ignorable operation))
2488  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
2489          component))
2490
2491(defmethod operation-description ((operation load-source-op) (component module))
2492  (declare (ignorable operation))
2493  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
2494
2495
2496;;;; -------------------------------------------------------------------------
2497;;;; test-op
2498
2499(defclass test-op (operation) ())
2500
2501(defmethod perform ((operation test-op) (c component))
2502  (declare (ignorable operation c))
2503  nil)
2504
2505(defmethod operation-done-p ((operation test-op) (c system))
2506  "Testing a system is _never_ done."
2507  (declare (ignorable operation c))
2508  nil)
2509
2510(defmethod component-depends-on :around ((o test-op) (c system))
2511  (declare (ignorable o))
2512  (cons `(load-op ,(component-name c)) (call-next-method)))
2513
2514
2515;;;; -------------------------------------------------------------------------
2516;;;; Invoking Operations
2517
2518(defgeneric* operate (operation-class system &key &allow-other-keys))
2519(defgeneric* perform-plan (plan &key))
2520
2521;;;; Separating this into a different function makes it more forward-compatible
2522(defun* cleanup-upgraded-asdf (old-version)
2523  (let ((new-version (asdf:asdf-version)))
2524    (unless (equal old-version new-version)
2525      (cond
2526        ((version-satisfies new-version old-version)
2527         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
2528                       old-version new-version))
2529        ((version-satisfies old-version new-version)
2530         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
2531               old-version new-version))
2532        (t
2533         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
2534                       old-version new-version)))
2535      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
2536        ;; Invalidate all systems but ASDF itself.
2537        (setf *defined-systems* (make-defined-systems-table))
2538        (register-system asdf)
2539        ;; If we're in the middle of something, restart it.
2540        (when *systems-being-defined*
2541          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
2542            (clrhash *systems-being-defined*)
2543            (dolist (s l) (find-system s nil))))
2544        t))))
2545
2546;;;; Try to upgrade of ASDF. If a different version was used, return T.
2547;;;; We need do that before we operate on anything that depends on ASDF.
2548(defun* upgrade-asdf ()
2549  (let ((version (asdf:asdf-version)))
2550    (handler-bind (((or style-warning warning) #'muffle-warning))
2551      (operate 'load-op :asdf :verbose nil))
2552    (cleanup-upgraded-asdf version)))
2553
2554(defmethod perform-plan ((steps list) &key)
2555  (let ((*package* *package*)
2556        (*readtable* *readtable*))
2557    (with-compilation-unit ()
2558      (loop :for (op . component) :in steps :do
2559        (perform-with-restarts op component)))))
2560
2561(defmethod operate (operation-class system &rest args
2562                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
2563                    &allow-other-keys)
2564  (declare (ignore force))
2565  (with-system-definitions ()
2566    (let* ((op (apply 'make-instance operation-class
2567                      :original-initargs args
2568                      args))
2569           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
2570           (system (etypecase system
2571                     (system system)
2572                     ((or string symbol) (find-system system)))))
2573      (unless (version-satisfies system version)
2574        (error 'missing-component-of-version :requires system :version version))
2575      (let ((steps (traverse op system)))
2576        (when (and (not (equal '("asdf") (component-find-path system)))
2577                   (find '("asdf") (mapcar 'cdr steps)
2578                         :test 'equal :key 'component-find-path)
2579                   (upgrade-asdf))
2580          ;; If we needed to upgrade ASDF to achieve our goal,
2581          ;; then do it specially as the first thing, then
2582          ;; invalidate all existing system
2583          ;; retry the whole thing with the new OPERATE function,
2584          ;; which on some implementations
2585          ;; has a new symbol shadowing the current one.
2586          (return-from operate
2587            (apply (find-symbol* 'operate :asdf) operation-class system args)))
2588        (perform-plan steps)
2589        (values op steps)))))
2590
2591(defun* oos (operation-class system &rest args &key force verbose version
2592            &allow-other-keys)
2593  (declare (ignore force verbose version))
2594  (apply 'operate operation-class system args))
2595
2596(let ((operate-docstring
2597  "Operate does three things:
2598
25991. It creates an instance of OPERATION-CLASS using any keyword parameters
2600as initargs.
26012. It finds the  asdf-system specified by SYSTEM (possibly loading
2602it from disk).
26033. It then calls TRAVERSE with the operation and system as arguments
2604
2605The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
2606handling code. If a VERSION argument is supplied, then operate also
2607ensures that the system found satisfies it using the VERSION-SATISFIES
2608method.
2609
2610Note that dependencies may cause the operation to invoke other
2611operations on the system or its components: the new operations will be
2612created with the same initargs as the original one.
2613"))
2614  (setf (documentation 'oos 'function)
2615        (format nil
2616                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
2617                operate-docstring))
2618  (setf (documentation 'operate 'function)
2619        operate-docstring))
2620
2621(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
2622  "Shorthand for `(operate 'asdf:load-op system)`.
2623See OPERATE for details."
2624  (declare (ignore force verbose version))
2625  (apply 'operate 'load-op system args)
2626  t)
2627
2628(defun* load-systems (&rest systems)
2629  (map () 'load-system systems))
2630
2631(defun* compile-system (system &rest args &key force verbose version
2632                       &allow-other-keys)
2633  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
2634for details."
2635  (declare (ignore force verbose version))
2636  (apply 'operate 'compile-op system args)
2637  t)
2638
2639(defun* test-system (system &rest args &key force verbose version
2640                    &allow-other-keys)
2641  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
2642details."
2643  (declare (ignore force verbose version))
2644  (apply 'operate 'test-op system args)
2645  t)
2646
2647;;;; -------------------------------------------------------------------------
2648;;;; Defsystem
2649
2650(defun* load-pathname ()
2651  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
2652
2653(defun* determine-system-pathname (pathname)
2654  ;; The defsystem macro calls us to determine
2655  ;; the pathname of a system as follows:
2656  ;; 1. the one supplied,
2657  ;; 2. derived from *load-pathname* via load-pathname
2658  ;; 3. taken from the *default-pathname-defaults* via default-directory
2659  (let* ((file-pathname (load-pathname))
2660         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
2661    (or (and pathname (subpathname directory-pathname pathname :type :directory))
2662        directory-pathname
2663        (default-directory))))
2664
2665(defun* class-for-type (parent type)
2666  (or (loop :for symbol :in (list
2667                             type
2668                             (find-symbol* type *package*)
2669                             (find-symbol* type :asdf))
2670        :for class = (and symbol (find-class symbol nil))
2671        :when (and class
2672                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
2673                                 class (find-class 'component)))
2674        :return class)
2675      (and (eq type :file)
2676           (or (and parent (module-default-component-class parent))
2677               (find-class *default-component-class*)))
2678      (sysdef-error "don't recognize component type ~A" type)))
2679
2680(defun* maybe-add-tree (tree op1 op2 c)
2681  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
2682Returns the new tree (which probably shares structure with the old one)"
2683  (let ((first-op-tree (assoc op1 tree)))
2684    (if first-op-tree
2685        (progn
2686          (aif (assoc op2 (cdr first-op-tree))
2687               (if (find c (cdr it) :test #'equal)
2688                   nil
2689                   (setf (cdr it) (cons c (cdr it))))
2690               (setf (cdr first-op-tree)
2691                     (acons op2 (list c) (cdr first-op-tree))))
2692          tree)
2693        (acons op1 (list (list op2 c)) tree))))
2694
2695(defun* union-of-dependencies (&rest deps)
2696  (let ((new-tree nil))
2697    (dolist (dep deps)
2698      (dolist (op-tree dep)
2699        (dolist (op  (cdr op-tree))
2700          (dolist (c (cdr op))
2701            (setf new-tree
2702                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
2703    new-tree))
2704
2705
2706(defvar *serial-depends-on* nil)
2707
2708(defun* sysdef-error-component (msg type name value)
2709  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
2710                type name value))
2711
2712(defun* check-component-input (type name weakly-depends-on
2713                              depends-on components in-order-to)
2714  "A partial test of the values of a component."
2715  (unless (listp depends-on)
2716    (sysdef-error-component ":depends-on must be a list."
2717                            type name depends-on))
2718  (unless (listp weakly-depends-on)
2719    (sysdef-error-component ":weakly-depends-on must be a list."
2720                            type name weakly-depends-on))
2721  (unless (listp components)
2722    (sysdef-error-component ":components must be NIL or a list of components."
2723                            type name components))
2724  (unless (and (listp in-order-to) (listp (car in-order-to)))
2725    (sysdef-error-component ":in-order-to must be NIL or a list of components."
2726                            type name in-order-to)))
2727
2728(defun* %remove-component-inline-methods (component)
2729  (dolist (name +asdf-methods+)
2730    (map ()
2731         ;; this is inefficient as most of the stored
2732         ;; methods will not be for this particular gf
2733         ;; But this is hardly performance-critical
2734         #'(lambda (m)
2735             (remove-method (symbol-function name) m))
2736         (component-inline-methods component)))
2737  ;; clear methods, then add the new ones
2738  (setf (component-inline-methods component) nil))
2739
2740(defun* %define-component-inline-methods (ret rest)
2741  (dolist (name +asdf-methods+)
2742    (let ((keyword (intern (symbol-name name) :keyword)))
2743      (loop :for data = rest :then (cddr data)
2744        :for key = (first data)
2745        :for value = (second data)
2746        :while data
2747        :when (eq key keyword) :do
2748        (destructuring-bind (op qual (o c) &body body) value
2749          (pushnew
2750           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
2751                             ,@body))
2752           (component-inline-methods ret)))))))
2753
2754(defun* %refresh-component-inline-methods (component rest)
2755  (%remove-component-inline-methods component)
2756  (%define-component-inline-methods component rest))
2757
2758(defun* parse-component-form (parent options)
2759  (destructuring-bind
2760        (type name &rest rest &key
2761              ;; the following list of keywords is reproduced below in the
2762              ;; remove-keys form.  important to keep them in sync
2763              components pathname default-component-class
2764              perform explain output-files operation-done-p
2765              weakly-depends-on
2766              depends-on serial in-order-to do-first
2767              (version nil versionp)
2768              ;; list ends
2769              &allow-other-keys) options
2770    (declare (ignorable perform explain output-files operation-done-p))
2771    (check-component-input type name weakly-depends-on depends-on components in-order-to)
2772
2773    (when (and parent
2774               (find-component parent name)
2775               ;; ignore the same object when rereading the defsystem
2776               (not
2777                (typep (find-component parent name)
2778                       (class-for-type parent type))))
2779      (error 'duplicate-names :name name))
2780
2781    (when versionp
2782      (unless (parse-version version nil)
2783        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
2784              version name parent)))
2785
2786    (let* ((args (list* :name (coerce-name name)
2787                        :pathname pathname
2788                        :parent parent
2789                        (remove-keys
2790                         '(components pathname default-component-class
2791                           perform explain output-files operation-done-p
2792                           weakly-depends-on depends-on serial in-order-to)
2793                         rest)))
2794           (ret (find-component parent name)))
2795      (when weakly-depends-on
2796        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
2797      (when *serial-depends-on*
2798        (push *serial-depends-on* depends-on))
2799      (if ret ; preserve identity
2800          (apply 'reinitialize-instance ret args)
2801          (setf ret (apply 'make-instance (class-for-type parent type) args)))
2802      (component-pathname ret) ; eagerly compute the absolute pathname
2803      (when (typep ret 'module)
2804        (setf (module-default-component-class ret)
2805              (or default-component-class
2806                  (and (typep parent 'module)
2807                       (module-default-component-class parent))))
2808        (let ((*serial-depends-on* nil))
2809          (setf (module-components ret)
2810                (loop
2811                  :for c-form :in components
2812                  :for c = (parse-component-form ret c-form)
2813                  :for name = (component-name c)
2814                  :collect c
2815                  :when serial :do (setf *serial-depends-on* name))))
2816        (compute-module-components-by-name ret))
2817
2818      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
2819
2820      (setf (component-in-order-to ret)
2821            (union-of-dependencies
2822             in-order-to
2823             `((compile-op (compile-op ,@depends-on))
2824               (load-op (load-op ,@depends-on)))))
2825      (setf (component-do-first ret)
2826            (union-of-dependencies
2827             do-first
2828             `((compile-op (load-op ,@depends-on)))))
2829
2830      (%refresh-component-inline-methods ret rest)
2831      ret)))
2832
2833(defun* reset-system (system &rest keys &key &allow-other-keys)
2834  (change-class (change-class system 'proto-system) 'system)
2835  (apply 'reinitialize-instance system keys))
2836
2837(defun* do-defsystem (name &rest options
2838                           &key pathname (class 'system)
2839                           defsystem-depends-on &allow-other-keys)
2840  ;; The system must be registered before we parse the body,
2841  ;; otherwise we recur when trying to find an existing system
2842  ;; of the same name to reuse options (e.g. pathname) from.
2843  ;; To avoid infinite recursion in cases where you defsystem a system
2844  ;; that is registered to a different location to find-system,
2845  ;; we also need to remember it in a special variable *systems-being-defined*.
2846  (with-system-definitions ()
2847    (let* ((name (coerce-name name))
2848           (registered (system-registered-p name))
2849           (registered! (if registered
2850                            (rplaca registered (get-universal-time))
2851                            (register-system (make-instance 'system :name name))))
2852           (system (reset-system (cdr registered!)
2853                                :name name :source-file (load-pathname)))
2854           (component-options (remove-keys '(:class) options)))
2855      (setf (gethash name *systems-being-defined*) system)
2856      (apply 'load-systems defsystem-depends-on)
2857      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
2858      ;; since the class might not be defined as part of those.
2859      (let ((class (class-for-type nil class)))
2860        (unless (eq (type-of system) class)
2861          (change-class system class)))
2862      (parse-component-form
2863       nil (list*
2864            :module name
2865            :pathname (determine-system-pathname pathname)
2866            component-options)))))
2867
2868(defmacro defsystem (name &body options)
2869  `(apply 'do-defsystem ',name ',options))
2870
2871;;;; ---------------------------------------------------------------------------
2872;;;; run-shell-command
2873;;;;
2874;;;; run-shell-command functions for other lisp implementations will be
2875;;;; gratefully accepted, if they do the same thing.
2876;;;; If the docstring is ambiguous, send a bug report.
2877;;;;
2878;;;; WARNING! The function below is mostly dysfunctional.
2879;;;; For instance, it will probably run fine on most implementations on Unix,
2880;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
2881;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
2882;;;; But behavior on Windows may vary wildly between implementations,
2883;;;; either relying on your having installed a POSIX sh, or going through
2884;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
2885;;;; what is easily expressible in said implementation.
2886;;;;
2887;;;; We probably should move this functionality to its own system and deprecate
2888;;;; use of it from the asdf package. However, this would break unspecified
2889;;;; existing software, so until a clear alternative exists, we can't deprecate
2890;;;; it, and even after it's been deprecated, we will support it for a few
2891;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
2892;;;;
2893;;;; As a suggested replacement which is portable to all ASDF-supported
2894;;;; implementations and operating systems except Genera, I recommend
2895;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its
2896;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
2897
2898(defun* run-shell-command (control-string &rest args)
2899  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
2900synchronously execute the result using a Bourne-compatible shell, with
2901output to *VERBOSE-OUT*.  Returns the shell's exit code."
2902  (let ((command (apply 'format nil control-string args)))
2903    (asdf-message "; $ ~A~%" command)
2904
2905    #+abcl
2906    (ext:run-shell-command command :output *verbose-out*)
2907
2908    #+allegro
2909    ;; will this fail if command has embedded quotes - it seems to work
2910    (multiple-value-bind (stdout stderr exit-code)
2911        (excl.osi:command-output
2912         #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
2913         #+mswindows command ; BEWARE!
2914         :input nil :whole nil
2915         #+mswindows :show-window #+mswindows :hide)
2916      (asdf-message "~{~&~a~%~}~%" stderr)
2917      (asdf-message "~{~&~a~%~}~%" stdout)
2918      exit-code)
2919
2920    #+clisp
2921    ;; CLISP returns NIL for exit status zero.
2922    (if *verbose-out*
2923        (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
2924                                    command))
2925               (outstream (ext:run-shell-command new-command :output :stream :wait t)))
2926            (multiple-value-bind (retval out-lines)
2927                (unwind-protect
2928                     (parse-clisp-shell-output outstream)
2929                  (ignore-errors (close outstream)))
2930              (asdf-message "~{~&~a~%~}~%" out-lines)
2931              retval))
2932        ;; there will be no output, just grab up the exit status
2933        (or (ext:run-shell-command command :output nil :wait t) 0))
2934
2935    #+clozure
2936    (nth-value 1
2937               (ccl:external-process-status
2938                (ccl:run-program
2939                 (cond
2940                   ((os-unix-p) "/bin/sh")
2941                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
2942                   (t (error "Unsupported OS")))
2943                 (if (os-unix-p) (list "-c" command) '())
2944                 :input nil :output *verbose-out* :wait t)))
2945
2946    #+(or cmu scl)
2947    (ext:process-exit-code
2948     (ext:run-program
2949      "/bin/sh"
2950      (list "-c" command)
2951      :input nil :output *verbose-out*))
2952
2953    #+cormanlisp
2954    (win32:system command)
2955
2956    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
2957    (ext:system command)
2958
2959    #+gcl
2960    (lisp:system command)
2961
2962    #+lispworks
2963    (apply 'system:call-system-showing-output command
2964           :show-cmd nil :prefix "" :output-stream *verbose-out*
2965           (when (os-unix-p) '(:shell-type "/bin/sh")))
2966
2967    #+mcl
2968    (ccl::with-cstrs ((%command command)) (_system %command))
2969
2970    #+sbcl
2971    (sb-ext:process-exit-code
2972     (apply 'sb-ext:run-program
2973            #+win32 "sh" #-win32 "/bin/sh"
2974            (list  "-c" command)
2975            :input nil :output *verbose-out*
2976            #+win32 '(:search t) #-win32 nil))
2977
2978    #+xcl
2979    (ext:run-shell-command command)
2980
2981    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
2982    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
2983
2984#+clisp
2985(defun* parse-clisp-shell-output (stream)
2986  "Helper function for running shell commands under clisp.  Parses a specially-
2987crafted output string to recover the exit status of the shell command and a
2988list of lines of output."
2989  (loop :with status-prefix = "ASDF-EXIT-STATUS "
2990    :with prefix-length = (length status-prefix)
2991    :with exit-status = -1 :with lines = ()
2992    :for line = (read-line stream nil nil)
2993    :while line :do (push line lines) :finally
2994    (let* ((last (car lines))
2995           (status (and last (>= (length last) prefix-length)
2996                        (string-equal last status-prefix :end1 prefix-length)
2997                        (parse-integer last :start prefix-length :junk-allowed t))))
2998      (when status
2999        (setf exit-status status)
3000        (pop lines) (when (equal "" (car lines)) (pop lines)))
3001      (return (values exit-status (reverse lines))))))
3002
3003;;;; ---------------------------------------------------------------------------
3004;;;; system-relative-pathname
3005
3006(defun* system-definition-pathname (x)
3007  ;; As of 2.014.8, we mean to make this function obsolete,
3008  ;; but that won't happen until all clients have been updated.
3009  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
3010  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
3011It used to expose ASDF internals with subtle differences with respect to
3012user expectations, that have been refactored away since.
3013We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
3014for a mostly compatible replacement that we're supporting,
3015or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
3016if that's whay you mean." ;;)
3017  (system-source-file x))
3018
3019(defmethod system-source-file ((system system))
3020  (%system-source-file system))
3021(defmethod system-source-file ((system-name string))
3022  (%system-source-file (find-system system-name)))
3023(defmethod system-source-file ((system-name symbol))
3024  (%system-source-file (find-system system-name)))
3025
3026(defun* system-source-directory (system-designator)
3027  "Return a pathname object corresponding to the
3028directory in which the system specification (.asd file) is
3029located."
3030  (pathname-directory-pathname (system-source-file system-designator)))
3031
3032(defun* relativize-directory (directory)
3033  (cond
3034    ((stringp directory)
3035     (list :relative directory))
3036    ((eq (car directory) :absolute)
3037     (cons :relative (cdr directory)))
3038    (t
3039     directory)))
3040
3041(defun* relativize-pathname-directory (pathspec)
3042  (let ((p (pathname pathspec)))
3043    (make-pathname
3044     :directory (relativize-directory (pathname-directory p))
3045     :defaults p)))
3046
3047(defun* system-relative-pathname (system name &key type)
3048  (subpathname (system-source-directory system) name :type type))
3049
3050
3051;;; ---------------------------------------------------------------------------
3052;;; implementation-identifier
3053;;;
3054;;; produce a string to identify current implementation.
3055;;; Initially stolen from SLIME's SWANK, rewritten since.
3056;;; We're back to runtime checking, for the sake of e.g. ABCL.
3057
3058(defun* first-feature (features)
3059  (dolist (x features)
3060    (multiple-value-bind (val feature)
3061        (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
3062      (when (featurep feature) (return val)))))
3063
3064(defun implementation-type ()
3065  (first-feature
3066   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
3067     :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
3068
3069(defun operating-system ()
3070  (first-feature
3071   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
3072     (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
3073     (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
3074     (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
3075     :genera)))
3076
3077(defun architecture ()
3078  (first-feature
3079   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
3080     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
3081     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
3082     :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
3083     :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
3084     ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
3085     ;; we may have to segregate the code still by architecture.
3086     (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
3087
3088(defun lisp-version-string ()
3089  (let ((s (lisp-implementation-version)))
3090    (car ; as opposed to OR, this idiom prevents some unreachable code warning
3091     (list
3092      #+allegro
3093      (format nil "~A~A~@[~A~]"
3094              excl::*common-lisp-version-number*
3095              ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
3096              (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
3097              ;; Note if not using International ACL
3098              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
3099              (excl:ics-target-case (:-ics "8")))
3100      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
3101      #+clisp
3102      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
3103      #+clozure
3104      (format nil "~d.~d-f~d" ; shorten for windows
3105              ccl::*openmcl-major-version*
3106              ccl::*openmcl-minor-version*
3107              (logand ccl::fasl-version #xFF))
3108      #+cmu (substitute #\- #\/ s)
3109      #+scl (format nil "~A~A" s
3110        ;; ANSI upper case vs lower case.
3111        (ecase ext:*case-mode* (:upper "") (:lower "l")))
3112      #+ecl (format nil "~A~@[-~A~]" s
3113                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
3114                      (subseq vcs-id 0 (min (length vcs-id) 8))))
3115      #+gcl (subseq s (1+ (position #\space s)))
3116      #+genera
3117      (multiple-value-bind (major minor) (sct:get-system-version "System")
3118        (format nil "~D.~D" major minor))
3119      #+mcl (subseq s 8) ; strip the leading "Version "
3120      s))))
3121
3122(defun* implementation-identifier ()
3123  (substitute-if
3124   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
3125   (format nil "~(~a~@{~@[-~a~]~}~)"
3126           (or (implementation-type) (lisp-implementation-type))
3127           (or (lisp-version-string) (lisp-implementation-version))
3128           (or (operating-system) (software-type))
3129           (or (architecture) (machine-type)))))
3130
3131
3132;;; ---------------------------------------------------------------------------
3133;;; Generic support for configuration files
3134
3135(defun inter-directory-separator ()
3136  (if (os-unix-p) #\: #\;))
3137
3138(defun* user-homedir ()
3139  (truenamize
3140   (pathname-directory-pathname
3141    #+mcl (current-user-homedir-pathname)
3142    #-mcl (user-homedir-pathname))))
3143
3144(defun* user-configuration-directories ()
3145  (let ((dirs
3146         `(,@(when (os-unix-p)
3147               (cons
3148                (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/")
3149                (loop :with dirs = (getenv "XDG_CONFIG_DIRS")
3150                  :for dir :in (split-string dirs :separator ":")
3151                  :collect (subpathname* dir "common-lisp/"))))
3152           ,@(when (os-windows-p)
3153               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
3154                                    (getenv "LOCALAPPDATA"))
3155                               "common-lisp/config/")
3156                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
3157                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
3158                                    (getenv "APPDATA"))
3159                                "common-lisp/config/")))
3160           ,(subpathname (user-homedir) ".config/common-lisp/"))))
3161    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
3162                       :from-end t :test 'equal)))
3163
3164(defun* system-configuration-directories ()
3165  (cond
3166    ((os-unix-p) '(#p"/etc/common-lisp/"))
3167    ((os-windows-p)
3168     (aif
3169      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
3170      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
3171                        (getenv "ALLUSERSAPPDATA")
3172                        (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))
3173                    "common-lisp/config/")
3174      (list it)))))
3175
3176(defun* in-first-directory (dirs x &key (direction :input))
3177  (loop :with fun = (ecase direction
3178                      ((nil :input :probe) 'probe-file*)
3179                      ((:output :io) 'identity))
3180    :for dir :in dirs
3181    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
3182
3183(defun* in-user-configuration-directory (x &key (direction :input))
3184  (in-first-directory (user-configuration-directories) x :direction direction))
3185(defun* in-system-configuration-directory (x &key (direction :input))
3186  (in-first-directory (system-configuration-directories) x :direction direction))
3187
3188(defun* configuration-inheritance-directive-p (x)
3189  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
3190    (or (member x kw)
3191        (and (length=n-p x 1) (member (car x) kw)))))
3192
3193(defun* report-invalid-form (reporter &rest args)
3194  (etypecase reporter
3195    (null
3196     (apply 'error 'invalid-configuration args))
3197    (function
3198     (apply reporter args))
3199    ((or symbol string)
3200     (apply 'error reporter args))
3201    (cons
3202     (apply 'apply (append reporter args)))))
3203
3204(defvar *ignored-configuration-form* nil)
3205
3206(defun* validate-configuration-form (form tag directive-validator
3207                                    &key location invalid-form-reporter)
3208  (unless (and (consp form) (eq (car form) tag))
3209    (setf *ignored-configuration-form* t)
3210    (report-invalid-form invalid-form-reporter :form form :location location)
3211    (return-from validate-configuration-form nil))
3212  (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
3213    :for directive :in (cdr form)
3214    :when (cond
3215            ((configuration-inheritance-directive-p directive)
3216             (incf inherit) t)
3217            ((eq directive :ignore-invalid-entries)
3218             (setf ignore-invalid-p t) t)
3219            ((funcall directive-validator directive)
3220             t)
3221            (ignore-invalid-p
3222             nil)
3223            (t
3224             (setf *ignored-configuration-form* t)
3225             (report-invalid-form invalid-form-reporter :form directive :location location)
3226             nil))
3227    :do (push directive x)
3228    :finally
3229    (unless (= inherit 1)
3230      (report-invalid-form invalid-form-reporter
3231             :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
3232                              :inherit-configuration :ignore-inherited-configuration)))
3233    (return (nreverse x))))
3234
3235(defun* validate-configuration-file (file validator &key description)
3236  (let ((forms (read-file-forms file)))
3237    (unless (length=n-p forms 1)
3238      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
3239             description forms))
3240    (funcall validator (car forms) :location file)))
3241
3242(defun* hidden-file-p (pathname)
3243  (equal (first-char (pathname-name pathname)) #\.))
3244
3245(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
3246  (apply 'directory pathname-spec
3247         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
3248                             #+clozure '(:follow-links nil)
3249                             #+clisp '(:circle t :if-does-not-exist :ignore)
3250                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
3251                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
3252                                      '(:resolve-symlinks nil))))))
3253
3254(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
3255  "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
3256be applied to the results to yield a configuration form.  Current
3257values of TAG include :source-registry and :output-translations."
3258  (let ((files (sort (ignore-errors
3259                       (remove-if
3260                        'hidden-file-p
3261                        (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
3262                     #'string< :key #'namestring)))
3263    `(,tag
3264      ,@(loop :for file :in files :append
3265          (loop :with ignore-invalid-p = nil
3266            :for form :in (read-file-forms file)
3267            :when (eq form :ignore-invalid-entries)
3268              :do (setf ignore-invalid-p t)
3269            :else
3270              :when (funcall validator form)
3271                :collect form
3272              :else
3273                :when ignore-invalid-p
3274                  :do (setf *ignored-configuration-form* t)
3275                :else
3276                  :do (report-invalid-form invalid-form-reporter :form form :location file)))
3277      :inherit-configuration)))
3278
3279
3280;;; ---------------------------------------------------------------------------
3281;;; asdf-output-translations
3282;;;
3283;;; this code is heavily inspired from
3284;;; asdf-binary-translations, common-lisp-controller and cl-launch.
3285;;; ---------------------------------------------------------------------------
3286
3287(defvar *output-translations* ()
3288  "Either NIL (for uninitialized), or a list of one element,
3289said element itself being a sorted list of mappings.
3290Each mapping is a pair of a source pathname and destination pathname,
3291and the order is by decreasing length of namestring of the source pathname.")
3292
3293(defvar *user-cache*
3294  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
3295    (or
3296     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
3297     (when (os-windows-p)
3298       (try (or #+lispworks (sys:get-folder-path :local-appdata)
3299                (getenv "LOCALAPPDATA")
3300                #+lispworks (sys:get-folder-path :appdata)
3301                (getenv "APPDATA"))
3302            "common-lisp" "cache" :implementation))
3303     '(:home ".cache" "common-lisp" :implementation))))
3304
3305(defun* output-translations ()
3306  (car *output-translations*))
3307
3308(defun* (setf output-translations) (new-value)
3309  (setf *output-translations*
3310        (list
3311         (stable-sort (copy-list new-value) #'>
3312                      :key #'(lambda (x)
3313                               (etypecase (car x)
3314                                 ((eql t) -1)
3315                                 (pathname
3316                                  (let ((directory (pathname-directory (car x))))
3317                                    (if (listp directory) (length directory) 0))))))))
3318  new-value)
3319
3320(defun* output-translations-initialized-p ()
3321  (and *output-translations* t))
3322
3323(defun* clear-output-translations ()
3324  "Undoes any initialization of the output translations.
3325You might want to call that before you dump an image that would be resumed
3326with a different configuration, so the configuration would be re-read then."
3327  (setf *output-translations* '())
3328  (values))
3329
3330(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
3331                          (values (or null pathname) &optional))
3332                resolve-location))
3333
3334(defun* resolve-relative-location-component (x &key directory wilden)
3335  (let ((r (etypecase x
3336             (pathname x)
3337             (string (coerce-pathname x :type (when directory :directory)))
3338             (cons
3339              (if (null (cdr x))
3340                  (resolve-relative-location-component
3341                   (car x) :directory directory :wilden wilden)
3342                  (let* ((car (resolve-relative-location-component
3343                               (car x) :directory t :wilden nil)))
3344                    (merge-pathnames*
3345                     (resolve-relative-location-component
3346                      (cdr x) :directory directory :wilden wilden)
3347                     car))))
3348             ((eql :default-directory)
3349              (relativize-pathname-directory (default-directory)))
3350             ((eql :*/) *wild-directory*)
3351             ((eql :**/) *wild-inferiors*)
3352             ((eql :*.*.*) *wild-file*)
3353             ((eql :implementation)
3354              (coerce-pathname (implementation-identifier) :type :directory))
3355             ((eql :implementation-type)
3356              (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
3357    (when (absolute-pathname-p r)
3358      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
3359    (if (or (pathnamep x) (not wilden)) r (wilden r))))
3360
3361(defvar *here-directory* nil
3362  "This special variable is bound to the currect directory during calls to
3363PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
3364directive.")
3365
3366(defun* resolve-absolute-location-component (x &key directory wilden)
3367  (let* ((r
3368          (etypecase x
3369            (pathname x)
3370            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
3371                      #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
3372                      (if directory (ensure-directory-pathname p) p)))
3373            (cons
3374             (return-from resolve-absolute-location-component
3375               (if (null (cdr x))
3376                   (resolve-absolute-location-component
3377                    (car x) :directory directory :wilden wilden)
3378                   (merge-pathnames*
3379                    (resolve-relative-location-component
3380                     (cdr x) :directory directory :wilden wilden)
3381                    (resolve-absolute-location-component
3382                     (car x) :directory t :wilden nil)))))
3383            ((eql :root)
3384             ;; special magic! we encode such paths as relative pathnames,
3385             ;; but it means "relative to the root of the source pathname's host and device".
3386             (return-from resolve-absolute-location-component
3387               (let ((p (make-pathname :directory '(:relative))))
3388                 (if wilden (wilden p) p))))
3389            ((eql :home) (user-homedir))
3390            ((eql :here)
3391             (resolve-location (or *here-directory*
3392                                   ;; give semantics in the case of use interactively
3393                                   :default-directory)
3394                          :directory t :wilden nil))
3395            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
3396            ((eql :system-cache)
3397             (error "Using the :system-cache is deprecated. ~%~
3398Please remove it from your ASDF configuration"))
3399            ((eql :default-directory) (default-directory))))
3400         (s (if (and wilden (not (pathnamep x)))
3401                (wilden r)
3402                r)))
3403    (unless (absolute-pathname-p s)
3404      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
3405    s))
3406
3407(defun* resolve-location (x &key directory wilden)
3408  (if (atom x)
3409      (resolve-absolute-location-component x :directory directory :wilden wilden)
3410      (loop :with path = (resolve-absolute-location-component
3411                          (car x) :directory (and (or directory (cdr x)) t)
3412                          :wilden (and wilden (null (cdr x))))
3413        :for (component . morep) :on (cdr x)
3414        :for dir = (and (or morep directory) t)
3415        :for wild = (and wilden (not morep))
3416        :do (setf path (merge-pathnames*
3417                        (resolve-relative-location-component
3418                         component :directory dir :wilden wild)
3419                        path))
3420        :finally (return path))))
3421
3422(defun* location-designator-p (x)
3423  (flet ((absolute-component-p (c)
3424           (typep c '(or string pathname
3425                      (member :root :home :here :user-cache :system-cache :default-directory))))
3426         (relative-component-p (c)
3427           (typep c '(or string pathname
3428                      (member :default-directory :*/ :**/ :*.*.*
3429                        :implementation :implementation-type)))))
3430    (or (typep x 'boolean)
3431        (absolute-component-p x)
3432        (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
3433
3434(defun* location-function-p (x)
3435  (and
3436   (consp x)
3437   (length=n-p x 2)
3438   (or (and (equal (first x) :function)
3439            (typep (second x) 'symbol))
3440       (and (equal (first x) 'lambda)
3441            (cddr x)
3442            (length=n-p (second x) 2)))))
3443
3444(defun* validate-output-translations-directive (directive)
3445  (or (member directive '(:enable-user-cache :disable-cache nil))
3446      (and (consp directive)
3447           (or (and (length=n-p directive 2)
3448                    (or (and (eq (first directive) :include)
3449                             (typep (second directive) '(or string pathname null)))
3450                        (and (location-designator-p (first directive))
3451                             (or (location-designator-p (second directive))
3452                                 (location-function-p (second directive))))))
3453               (and (length=n-p directive 1)
3454                    (location-designator-p (first directive)))))))
3455
3456(defun* validate-output-translations-form (form &key location)
3457  (validate-configuration-form
3458   form
3459   :output-translations
3460   'validate-output-translations-directive
3461   :location location :invalid-form-reporter 'invalid-output-translation))
3462
3463(defun* validate-output-translations-file (file)
3464  (validate-configuration-file
3465   file 'validate-output-translations-form :description "output translations"))
3466
3467(defun* validate-output-translations-directory (directory)
3468  (validate-configuration-directory
3469   directory :output-translations 'validate-output-translations-directive
3470   :invalid-form-reporter 'invalid-output-translation))
3471
3472(defun* parse-output-translations-string (string &key location)
3473  (cond
3474    ((or (null string) (equal string ""))
3475     '(:output-translations :inherit-configuration))
3476    ((not (stringp string))
3477     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
3478    ((eql (char string 0) #\")
3479     (parse-output-translations-string (read-from-string string) :location location))
3480    ((eql (char string 0) #\()
3481     (validate-output-translations-form (read-from-string string) :location location))
3482    (t
3483     (loop
3484      :with inherit = nil
3485      :with directives = ()
3486      :with start = 0
3487      :with end = (length string)
3488      :with source = nil
3489      :with separator = (inter-directory-separator)
3490      :for i = (or (position separator string :start start) end) :do
3491      (let ((s (subseq string start i)))
3492        (cond
3493          (source
3494           (push (list source (if (equal "" s) nil s)) directives)
3495           (setf source nil))
3496          ((equal "" s)
3497           (when inherit
3498             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
3499                    string))
3500           (setf inherit t)
3501           (push :inherit-configuration directives))
3502          (t
3503           (setf source s)))
3504        (setf start (1+ i))
3505        (when (> start end)
3506          (when source
3507            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
3508                   string))
3509          (unless inherit
3510            (push :ignore-inherited-configuration directives))
3511          (return `(:output-translations ,@(nreverse directives)))))))))
3512
3513(defparameter *default-output-translations*
3514  '(environment-output-translations
3515    user-output-translations-pathname
3516    user-output-translations-directory-pathname
3517    system-output-translations-pathname
3518    system-output-translations-directory-pathname))
3519
3520(defun* wrapping-output-translations ()
3521  `(:output-translations
3522    ;; Some implementations have precompiled ASDF systems,
3523    ;; so we must disable translations for implementation paths.
3524    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
3525                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
3526    ;; The below two are not needed: no precompiled ASDF system there
3527    ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
3528    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
3529    ;; All-import, here is where we want user stuff to be:
3530    :inherit-configuration
3531    ;; These are for convenience, and can be overridden by the user:
3532    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
3533    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
3534    ;; We enable the user cache by default, and here is the place we do:
3535    :enable-user-cache))
3536
3537(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
3538(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
3539
3540(defun* user-output-translations-pathname (&key (direction :input))
3541  (in-user-configuration-directory *output-translations-file* :direction direction))
3542(defun* system-output-translations-pathname (&key (direction :input))
3543  (in-system-configuration-directory *output-translations-file* :direction direction))
3544(defun* user-output-translations-directory-pathname (&key (direction :input))
3545  (in-user-configuration-directory *output-translations-directory* :direction direction))
3546(defun* system-output-translations-directory-pathname (&key (direction :input))
3547  (in-system-configuration-directory *output-translations-directory* :direction direction))
3548(defun* environment-output-translations ()
3549  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
3550
3551(defgeneric* process-output-translations (spec &key inherit collect))
3552(declaim (ftype (function (t &key (:collect (or symbol function))) t)
3553                inherit-output-translations))
3554(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
3555                process-output-translations-directive))
3556
3557(defmethod process-output-translations ((x symbol) &key
3558                                        (inherit *default-output-translations*)
3559                                        collect)
3560  (process-output-translations (funcall x) :inherit inherit :collect collect))
3561(defmethod process-output-translations ((pathname pathname) &key inherit collect)
3562  (cond
3563    ((directory-pathname-p pathname)
3564     (process-output-translations (validate-output-translations-directory pathname)
3565                                  :inherit inherit :collect collect))
3566    ((probe-file* pathname)
3567     (process-output-translations (validate-output-translations-file pathname)
3568                                  :inherit inherit :collect collect))
3569    (t
3570     (inherit-output-translations inherit :collect collect))))
3571(defmethod process-output-translations ((string string) &key inherit collect)
3572  (process-output-translations (parse-output-translations-string string)
3573                               :inherit inherit :collect collect))
3574(defmethod process-output-translations ((x null) &key inherit collect)
3575  (declare (ignorable x))
3576  (inherit-output-translations inherit :collect collect))
3577(defmethod process-output-translations ((form cons) &key inherit collect)
3578  (dolist (directive (cdr (validate-output-translations-form form)))
3579    (process-output-translations-directive directive :inherit inherit :collect collect)))
3580
3581(defun* inherit-output-translations (inherit &key collect)
3582  (when inherit
3583    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
3584
3585(defun* process-output-translations-directive (directive &key inherit collect)
3586  (if (atom directive)
3587      (ecase directive
3588        ((:enable-user-cache)
3589         (process-output-translations-directive '(t :user-cache) :collect collect))
3590        ((:disable-cache)
3591         (process-output-translations-directive '(t t) :collect collect))
3592        ((:inherit-configuration)
3593         (inherit-output-translations inherit :collect collect))
3594        ((:ignore-inherited-configuration :ignore-invalid-entries nil)
3595         nil))
3596      (let ((src (first directive))
3597            (dst (second directive)))
3598        (if (eq src :include)
3599            (when dst
3600              (process-output-translations (pathname dst) :inherit nil :collect collect))
3601            (when src
3602              (let ((trusrc (or (eql src t)
3603                                (let ((loc (resolve-location src :directory t :wilden t)))
3604                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
3605                (cond
3606                  ((location-function-p dst)
3607                   (funcall collect
3608                            (list trusrc
3609                                  (if (symbolp (second dst))
3610                                      (fdefinition (second dst))
3611                                      (eval (second dst))))))
3612                  ((eq dst t)
3613                   (funcall collect (list trusrc t)))
3614                  (t
3615                   (let* ((trudst (if dst
3616                                      (resolve-location dst :directory t :wilden t)
3617                                      trusrc))
3618                          (wilddst (merge-pathnames* *wild-file* trudst)))
3619                     (funcall collect (list wilddst t))
3620                     (funcall collect (list trusrc trudst)))))))))))
3621
3622(defun* compute-output-translations (&optional parameter)
3623  "read the configuration, return it"
3624  (remove-duplicates
3625   (while-collecting (c)
3626     (inherit-output-translations
3627      `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
3628   :test 'equal :from-end t))
3629
3630(defvar *output-translations-parameter* nil)
3631
3632(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
3633  "read the configuration, initialize the internal configuration variable,
3634return the configuration"
3635  (setf *output-translations-parameter* parameter
3636        (output-translations) (compute-output-translations parameter)))
3637
3638(defun* disable-output-translations ()
3639  "Initialize output translations in a way that maps every file to itself,
3640effectively disabling the output translation facility."
3641  (initialize-output-translations
3642   '(:output-translations :disable-cache :ignore-inherited-configuration)))
3643
3644;; checks an initial variable to see whether the state is initialized
3645;; or cleared. In the former case, return current configuration; in
3646;; the latter, initialize.  ASDF will call this function at the start
3647;; of (asdf:find-system).
3648(defun* ensure-output-translations ()
3649  (if (output-translations-initialized-p)
3650      (output-translations)
3651      (initialize-output-translations)))
3652
3653(defun* translate-pathname* (path absolute-source destination &optional root source)
3654  (declare (ignore source))
3655  (cond
3656    ((functionp destination)
3657     (funcall destination path absolute-source))
3658    ((eq destination t)
3659     path)
3660    ((not (pathnamep destination))
3661     (error "Invalid destination"))
3662    ((not (absolute-pathname-p destination))
3663     (translate-pathname path absolute-source (merge-pathnames* destination root)))
3664    (root
3665     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
3666    (t
3667     (translate-pathname path absolute-source destination))))
3668
3669(defun* apply-output-translations (path)
3670  #+cormanlisp (truenamize path) #-cormanlisp
3671  (etypecase path
3672    (logical-pathname
3673     path)
3674    ((or pathname string)
3675     (ensure-output-translations)
3676     (loop :with p = (truenamize path)
3677       :for (source destination) :in (car *output-translations*)
3678       :for root = (when (or (eq source t)
3679                             (and (pathnamep source)
3680                                  (not (absolute-pathname-p source))))
3681                     (pathname-root p))
3682       :for absolute-source = (cond
3683                                ((eq source t) (wilden root))
3684                                (root (merge-pathnames* source root))
3685                                (t source))
3686       :when (or (eq source t) (pathname-match-p p absolute-source))
3687       :return (translate-pathname* p absolute-source destination root source)
3688       :finally (return p)))))
3689
3690(defmethod output-files :around (operation component)
3691  "Translate output files, unless asked not to"
3692  operation component ;; hush genera, not convinced by declare ignorable(!)
3693  (values
3694   (multiple-value-bind (files fixedp) (call-next-method)
3695     (if fixedp
3696         files
3697         (mapcar #'apply-output-translations files)))
3698   t))
3699
3700(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
3701  (if (absolute-pathname-p output-file)
3702      ;; what cfp should be doing, w/ mp* instead of mp
3703      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
3704             (defaults (make-pathname
3705                        :type type :defaults (merge-pathnames* input-file))))
3706        (merge-pathnames* output-file defaults))
3707      (apply-output-translations
3708       (apply 'compile-file-pathname input-file keys))))
3709
3710(defun* tmpize-pathname (x)
3711  (make-pathname
3712   :name (strcat "ASDF-TMP-" (pathname-name x))
3713   :defaults x))
3714
3715(defun* delete-file-if-exists (x)
3716  (when (and x (probe-file* x))
3717    (delete-file x)))
3718
3719(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
3720  (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
3721         (tmp-file (tmpize-pathname output-file))
3722         (status :error))
3723    (multiple-value-bind (output-truename warnings-p failure-p)
3724        (apply 'compile-file input-file :output-file tmp-file keys)
3725      (cond
3726        (failure-p
3727         (setf status *compile-file-failure-behaviour*))
3728        (warnings-p
3729         (setf status *compile-file-warnings-behaviour*))
3730        (t
3731         (setf status :success)))
3732      (ecase status
3733        ((:success :warn :ignore)
3734         (delete-file-if-exists output-file)
3735         (when output-truename
3736           (rename-file output-truename output-file)
3737           (setf output-truename output-file)))
3738        (:error
3739         (delete-file-if-exists output-truename)
3740         (setf output-truename nil)))
3741      (values output-truename warnings-p failure-p))))
3742
3743#+abcl
3744(defun* translate-jar-pathname (source wildcard)
3745  (declare (ignore wildcard))
3746  (let* ((p (pathname (first (pathname-device source))))
3747         (root (format nil "/___jar___file___root___/~@[~A/~]"
3748                       (and (find :windows *features*)
3749                            (pathname-device p)))))
3750    (apply-output-translations
3751     (merge-pathnames*
3752      (relativize-pathname-directory source)
3753      (merge-pathnames*
3754       (relativize-pathname-directory (ensure-directory-pathname p))
3755       root)))))
3756
3757;;;; -----------------------------------------------------------------
3758;;;; Compatibility mode for ASDF-Binary-Locations
3759
3760(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
3761  (declare (ignorable operation-class system args))
3762  (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
3763    (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
3764ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
3765which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
3766and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
3767In case you insist on preserving your previous A-B-L configuration, but
3768do not know how to achieve the same effect with A-O-T, you may use function
3769ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
3770call that function where you would otherwise have loaded and configured A-B-L.")))
3771
3772(defun* enable-asdf-binary-locations-compatibility
3773    (&key
3774     (centralize-lisp-binaries nil)
3775     (default-toplevel-directory
3776         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
3777     (include-per-user-information nil)
3778     (map-all-source-files (or #+(or ecl clisp) t nil))
3779     (source-to-target-mappings nil))
3780  #+(or ecl clisp)
3781  (when (null map-all-source-files)
3782    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
3783  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
3784         (mapped-files (if map-all-source-files *wild-file*
3785                           (make-pathname :type fasl-type :defaults *wild-file*)))
3786         (destination-directory
3787          (if centralize-lisp-binaries
3788              `(,default-toplevel-directory
3789                ,@(when include-per-user-information
3790                        (cdr (pathname-directory (user-homedir))))
3791                :implementation ,*wild-inferiors*)
3792              `(:root ,*wild-inferiors* :implementation))))
3793    (initialize-output-translations
3794     `(:output-translations
3795       ,@source-to-target-mappings
3796       ((:root ,*wild-inferiors* ,mapped-files)
3797        (,@destination-directory ,mapped-files))
3798       (t t)
3799       :ignore-inherited-configuration))))
3800
3801;;;; -----------------------------------------------------------------
3802;;;; Source Registry Configuration, by Francois-Rene Rideau
3803;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
3804
3805;; Using ack 1.2 exclusions
3806(defvar *default-source-registry-exclusions*
3807  '(".bzr" ".cdv"
3808    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
3809    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
3810    "_sgbak" "autom4te.cache" "cover_db" "_build"
3811    "debian")) ;; debian often builds stuff under the debian directory... BAD.
3812
3813(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
3814
3815(defvar *source-registry* nil
3816  "Either NIL (for uninitialized), or an equal hash-table, mapping
3817system names to pathnames of .asd files")
3818
3819(defun* source-registry-initialized-p ()
3820  (typep *source-registry* 'hash-table))
3821
3822(defun* clear-source-registry ()
3823  "Undoes any initialization of the source registry.
3824You might want to call that before you dump an image that would be resumed
3825with a different configuration, so the configuration would be re-read then."
3826  (setf *source-registry* nil)
3827  (values))
3828
3829(defparameter *wild-asd*
3830  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
3831
3832(defun* filter-logical-directory-results (directory entries merger)
3833  (if (typep directory 'logical-pathname)
3834      ;; Try hard to not resolve logical-pathname into physical pathnames;
3835      ;; otherwise logical-pathname users/lovers will be disappointed.
3836      ;; If directory* could use some implementation-dependent magic,
3837      ;; we will have logical pathnames already; otherwise,
3838      ;; we only keep pathnames for which specifying the name and
3839      ;; translating the LPN commute.
3840      (loop :for f :in entries
3841        :for p = (or (and (typep f 'logical-pathname) f)
3842                     (let* ((u (ignore-errors (funcall merger f))))
3843                       ;; The first u avoids a cumbersome (truename u) error
3844                       (and u (equal (ignore-errors (truename u)) f) u)))
3845        :when p :collect p)
3846      entries))
3847
3848(defun* directory-files (directory &optional (pattern *wild-file*))
3849  (when (wild-pathname-p directory)
3850    (error "Invalid wild in ~S" directory))
3851  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
3852    (error "Invalid file pattern ~S" pattern))
3853  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
3854    (filter-logical-directory-results
3855     directory entries
3856     #'(lambda (f)
3857         (make-pathname :defaults directory
3858                        :name (pathname-name f) :type (ununspecific (pathname-type f))
3859                        :version (ununspecific (pathname-version f)))))))
3860
3861(defun* directory-asd-files (directory)
3862  (directory-files directory *wild-asd*))
3863
3864(defun* subdirectories (directory)
3865  (let* ((directory (ensure-directory-pathname directory))
3866         #-(or abcl cormanlisp genera xcl)
3867         (wild (merge-pathnames*
3868                #-(or abcl allegro cmu lispworks sbcl scl xcl)
3869                *wild-directory*
3870                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
3871                directory))
3872         (dirs
3873          #-(or abcl cormanlisp genera xcl)
3874          (ignore-errors
3875            (directory* wild . #.(or #+clozure '(:directories t :files nil)
3876                                     #+mcl '(:directories t))))
3877          #+(or abcl xcl) (system:list-directory directory)
3878          #+cormanlisp (cl::directory-subdirs directory)
3879          #+genera (fs:directory-list directory))
3880         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
3881         (dirs (loop :for x :in dirs
3882                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
3883                          #+allegro (excl:probe-directory x)
3884                          #+(or cmu sbcl scl) (directory-pathname-p x)
3885                          #+genera (getf (cdr x) :directory)
3886                          #+lispworks (lw:file-directory-p x)
3887                 :when d :collect #+(or abcl allegro xcl) d
3888                                  #+genera (ensure-directory-pathname (first x))
3889                                  #+(or cmu lispworks sbcl scl) x)))
3890    (filter-logical-directory-results
3891     directory dirs
3892     (let ((prefix (normalize-pathname-directory-component
3893                    (pathname-directory directory))))
3894       #'(lambda (d)
3895           (let ((dir (normalize-pathname-directory-component
3896                       (pathname-directory d))))
3897             (and (consp dir) (consp (cdr dir))
3898                  (make-pathname
3899                   :defaults directory :name nil :type nil :version nil
3900                   :directory (append prefix (last dir))))))))))
3901
3902(defun* collect-asds-in-directory (directory collect)
3903  (map () collect (directory-asd-files directory)))
3904
3905(defun* collect-sub*directories (directory collectp recursep collector)
3906  (when (funcall collectp directory)
3907    (funcall collector directory))
3908  (dolist (subdir (subdirectories directory))
3909    (when (funcall recursep subdir)
3910      (collect-sub*directories subdir collectp recursep collector))))
3911
3912(defun* collect-sub*directories-asd-files
3913    (directory &key
3914     (exclude *default-source-registry-exclusions*)
3915     collect)
3916  (collect-sub*directories
3917   directory
3918   (constantly t)
3919   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
3920   #'(lambda (dir) (collect-asds-in-directory dir collect))))
3921
3922(defun* validate-source-registry-directive (directive)
3923  (or (member directive '(:default-registry))
3924      (and (consp directive)
3925           (let ((rest (rest directive)))
3926             (case (first directive)
3927               ((:include :directory :tree)
3928                (and (length=n-p rest 1)
3929                     (location-designator-p (first rest))))
3930               ((:exclude :also-exclude)
3931                (every #'stringp rest))
3932               ((:default-registry)
3933                (null rest)))))))
3934
3935(defun* validate-source-registry-form (form &key location)
3936  (validate-configuration-form
3937   form :source-registry 'validate-source-registry-directive
3938   :location location :invalid-form-reporter 'invalid-source-registry))
3939
3940(defun* validate-source-registry-file (file)
3941  (validate-configuration-file
3942   file 'validate-source-registry-form :description "a source registry"))
3943
3944(defun* validate-source-registry-directory (directory)
3945  (validate-configuration-directory
3946   directory :source-registry 'validate-source-registry-directive
3947   :invalid-form-reporter 'invalid-source-registry))
3948
3949(defun* parse-source-registry-string (string &key location)
3950  (cond
3951    ((or (null string) (equal string ""))
3952     '(:source-registry :inherit-configuration))
3953    ((not (stringp string))
3954     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
3955    ((find (char string 0) "\"(")
3956     (validate-source-registry-form (read-from-string string) :location location))
3957    (t
3958     (loop
3959      :with inherit = nil
3960      :with directives = ()
3961      :with start = 0
3962      :with end = (length string)
3963      :with separator = (inter-directory-separator)
3964      :for pos = (position separator string :start start) :do
3965      (let ((s (subseq string start (or pos end))))
3966        (flet ((check (dir)
3967                 (unless (absolute-pathname-p dir)
3968                   (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
3969                 dir))
3970          (cond
3971            ((equal "" s) ; empty element: inherit
3972             (when inherit
3973               (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
3974                      string))
3975             (setf inherit t)
3976             (push ':inherit-configuration directives))
3977            ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
3978             (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
3979            (t
3980             (push `(:directory ,(check s)) directives))))
3981        (cond
3982          (pos
3983           (setf start (1+ pos)))
3984          (t
3985           (unless inherit
3986             (push '(:ignore-inherited-configuration) directives))
3987           (return `(:source-registry ,@(nreverse directives))))))))))
3988
3989(defun* register-asd-directory (directory &key recurse exclude collect)
3990  (if (not recurse)
3991      (collect-asds-in-directory directory collect)
3992      (collect-sub*directories-asd-files
3993       directory :exclude exclude :collect collect)))
3994
3995(defparameter *default-source-registries*
3996  '(environment-source-registry
3997    user-source-registry
3998    user-source-registry-directory
3999    system-source-registry
4000    system-source-registry-directory
4001    default-source-registry))
4002
4003(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
4004(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
4005
4006(defun* wrapping-source-registry ()
4007  `(:source-registry
4008    #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
4009    :inherit-configuration
4010    #+cmu (:tree #p"modules:")
4011    #+scl (:tree #p"file://modules/")))
4012(defun* default-source-registry ()
4013  `(:source-registry
4014    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
4015    (:directory ,(default-directory))
4016      ,@(loop :for dir :in
4017          `(,@(when (os-unix-p)
4018                `(,(or (getenv "XDG_DATA_HOME")
4019                       (subpathname (user-homedir) ".local/share/"))
4020                  ,@(split-string (or (getenv "XDG_DATA_DIRS")
4021                                      "/usr/local/share:/usr/share")
4022                                  :separator ":")))
4023            ,@(when (os-windows-p)
4024                `(,(or #+lispworks (sys:get-folder-path :local-appdata)
4025                       (getenv "LOCALAPPDATA"))
4026                  ,(or #+lispworks (sys:get-folder-path :appdata)
4027                       (getenv "APPDATA"))
4028                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
4029                       (getenv "ALLUSERSAPPDATA")
4030                       (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")))))
4031          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
4032          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
4033      :inherit-configuration))
4034(defun* user-source-registry (&key (direction :input))
4035  (in-user-configuration-directory *source-registry-file* :direction direction))
4036(defun* system-source-registry (&key (direction :input))
4037  (in-system-configuration-directory *source-registry-file* :direction direction))
4038(defun* user-source-registry-directory (&key (direction :input))
4039  (in-user-configuration-directory *source-registry-directory* :direction direction))
4040(defun* system-source-registry-directory (&key (direction :input))
4041  (in-system-configuration-directory *source-registry-directory* :direction direction))
4042(defun* environment-source-registry ()
4043  (getenv "CL_SOURCE_REGISTRY"))
4044
4045(defgeneric* process-source-registry (spec &key inherit register))
4046(declaim (ftype (function (t &key (:register (or symbol function))) t)
4047                inherit-source-registry))
4048(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
4049                process-source-registry-directive))
4050
4051(defmethod process-source-registry ((x symbol) &key inherit register)
4052  (process-source-registry (funcall x) :inherit inherit :register register))
4053(defmethod process-source-registry ((pathname pathname) &key inherit register)
4054  (cond
4055    ((directory-pathname-p pathname)
4056     (let ((*here-directory* (truenamize pathname)))
4057       (process-source-registry (validate-source-registry-directory pathname)
4058                                :inherit inherit :register register)))
4059    ((probe-file* pathname)
4060     (let ((*here-directory* (pathname-directory-pathname pathname)))
4061       (process-source-registry (validate-source-registry-file pathname)
4062                                :inherit inherit :register register)))
4063    (t
4064     (inherit-source-registry inherit :register register))))
4065(defmethod process-source-registry ((string string) &key inherit register)
4066  (process-source-registry (parse-source-registry-string string)
4067                           :inherit inherit :register register))
4068(defmethod process-source-registry ((x null) &key inherit register)
4069  (declare (ignorable x))
4070  (inherit-source-registry inherit :register register))
4071(defmethod process-source-registry ((form cons) &key inherit register)
4072  (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
4073    (dolist (directive (cdr (validate-source-registry-form form)))
4074      (process-source-registry-directive directive :inherit inherit :register register))))
4075
4076(defun* inherit-source-registry (inherit &key register)
4077  (when inherit
4078    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
4079
4080(defun* process-source-registry-directive (directive &key inherit register)
4081  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
4082    (ecase kw
4083      ((:include)
4084       (destructuring-bind (pathname) rest
4085         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
4086      ((:directory)
4087       (destructuring-bind (pathname) rest
4088         (when pathname
4089           (funcall register (resolve-location pathname :directory t)))))
4090      ((:tree)
4091       (destructuring-bind (pathname) rest
4092         (when pathname
4093           (funcall register (resolve-location pathname :directory t)
4094                    :recurse t :exclude *source-registry-exclusions*))))
4095      ((:exclude)
4096       (setf *source-registry-exclusions* rest))
4097      ((:also-exclude)
4098       (appendf *source-registry-exclusions* rest))
4099      ((:default-registry)
4100       (inherit-source-registry '(default-source-registry) :register register))
4101      ((:inherit-configuration)
4102       (inherit-source-registry inherit :register register))
4103      ((:ignore-inherited-configuration)
4104       nil)))
4105  nil)
4106
4107(defun* flatten-source-registry (&optional parameter)
4108  (remove-duplicates
4109   (while-collecting (collect)
4110     (let ((*default-pathname-defaults* (default-directory)))
4111       (inherit-source-registry
4112        `(wrapping-source-registry
4113          ,parameter
4114          ,@*default-source-registries*)
4115        :register #'(lambda (directory &key recurse exclude)
4116                      (collect (list directory :recurse recurse :exclude exclude)))))
4117     :test 'equal :from-end t)))
4118
4119;; Will read the configuration and initialize all internal variables.
4120(defun* compute-source-registry (&optional parameter (registry *source-registry*))
4121  (dolist (entry (flatten-source-registry parameter))
4122    (destructuring-bind (directory &key recurse exclude) entry
4123      (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
4124        (register-asd-directory
4125         directory :recurse recurse :exclude exclude :collect
4126         #'(lambda (asd)
4127             (let* ((name (pathname-name asd))
4128                    (name (if (typep asd 'logical-pathname)
4129                              ;; logical pathnames are upper-case,
4130                              ;; at least in the CLHS and on SBCL,
4131                              ;; yet (coerce-name :foo) is lower-case.
4132                              ;; won't work well with (load-system "Foo")
4133                              ;; instead of (load-system 'foo)
4134                              (string-downcase name)
4135                              name)))
4136               (cond
4137                 ((gethash name registry) ; already shadowed by something else
4138                  nil)
4139                 ((gethash name h) ; conflict at current level
4140                  (when *asdf-verbose*
4141                    (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
4142                                found several entries for ~A - picking ~S over ~S~:>")
4143                          directory recurse name (gethash name h) asd)))
4144                 (t
4145                  (setf (gethash name registry) asd)
4146                  (setf (gethash name h) asd))))))
4147        h)))
4148  (values))
4149
4150(defvar *source-registry-parameter* nil)
4151
4152(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
4153  (setf *source-registry-parameter* parameter)
4154  (setf *source-registry* (make-hash-table :test 'equal))
4155  (compute-source-registry parameter))
4156
4157;; Checks an initial variable to see whether the state is initialized
4158;; or cleared. In the former case, return current configuration; in
4159;; the latter, initialize.  ASDF will call this function at the start
4160;; of (asdf:find-system) to make sure the source registry is initialized.
4161;; However, it will do so *without* a parameter, at which point it
4162;; will be too late to provide a parameter to this function, though
4163;; you may override the configuration explicitly by calling
4164;; initialize-source-registry directly with your parameter.
4165(defun* ensure-source-registry (&optional parameter)
4166  (unless (source-registry-initialized-p)
4167    (initialize-source-registry parameter))
4168  (values))
4169
4170(defun* sysdef-source-registry-search (system)
4171  (ensure-source-registry)
4172  (values (gethash (coerce-name system) *source-registry*)))
4173
4174(defun* clear-configuration ()
4175  (clear-source-registry)
4176  (clear-output-translations))
4177
4178
4179;;; ECL support for COMPILE-OP / LOAD-OP
4180;;;
4181;;; In ECL, these operations produce both FASL files and the
4182;;; object files that they are built from. Having both of them allows
4183;;; us to later on reuse the object files for bundles, libraries,
4184;;; standalone executables, etc.
4185;;;
4186;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
4187;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
4188;;;
4189#+ecl
4190(progn
4191  (setf *compile-op-compile-file-function* 'ecl-compile-file)
4192
4193  (defun use-ecl-byte-compiler-p ()
4194    (member :ecl-bytecmp *features*))
4195
4196  (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
4197    (if (use-ecl-byte-compiler-p)
4198        (apply 'compile-file* input-file keys)
4199        (multiple-value-bind (object-file flags1 flags2)
4200            (apply 'compile-file* input-file :system-p t keys)
4201          (values (and object-file
4202                       (c::build-fasl (compile-file-pathname object-file :type :fasl)
4203                                      :lisp-files (list object-file))
4204                       object-file)
4205                  flags1
4206                  flags2))))
4207
4208  (defmethod output-files ((operation compile-op) (c cl-source-file))
4209    (declare (ignorable operation))
4210    (let* ((p (lispize-pathname (component-pathname c)))
4211           (f (compile-file-pathname p :type :fasl)))
4212      (if (use-ecl-byte-compiler-p)
4213          (list f)
4214          (list (compile-file-pathname p :type :object) f))))
4215
4216  (defmethod perform ((o load-op) (c cl-source-file))
4217    (map () #'load
4218         (loop :for i :in (input-files o c)
4219           :unless (string= (pathname-type i) "fas")
4220               :collect (compile-file-pathname (lispize-pathname i))))))
4221
4222;;;; -----------------------------------------------------------------
4223;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
4224;;;;
4225(defvar *require-asdf-operator* 'load-op)
4226
4227(defun* module-provide-asdf (name)
4228  (handler-bind
4229      ((style-warning #'muffle-warning)
4230       #-genera
4231       (missing-component (constantly nil))
4232       (error #'(lambda (e)
4233                  (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
4234                          name e))))
4235    (let ((*verbose-out* (make-broadcast-stream))
4236          (system (find-system (string-downcase name) nil)))
4237      (when system
4238        (operate *require-asdf-operator* system :verbose nil)
4239        t))))
4240
4241#+(or abcl clisp clozure cmu ecl sbcl)
4242(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
4243  (when x
4244    (eval `(pushnew 'module-provide-asdf
4245            #+abcl sys::*module-provider-functions*
4246            #+clisp ,x
4247            #+clozure ccl:*module-provider-functions*
4248            #+(or cmu ecl) ext:*module-provider-functions*
4249            #+sbcl sb-ext:*module-provider-functions*))))
4250
4251
4252;;;; -------------------------------------------------------------------------
4253;;;; Cleanups after hot-upgrade.
4254;;;; Things to do in case we're upgrading from a previous version of ASDF.
4255;;;; See https://bugs.launchpad.net/asdf/+bug/485687
4256;;;;
4257
4258;;; If a previous version of ASDF failed to read some configuration, try again.
4259(when *ignored-configuration-form*
4260  (clear-configuration)
4261  (setf *ignored-configuration-form* nil))
4262
4263;;;; -----------------------------------------------------------------
4264;;;; Done!
4265(when *load-verbose*
4266  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
4267
4268#+allegro
4269(eval-when (:compile-toplevel :execute)
4270  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
4271    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
4272
4273(pushnew :asdf *features*)
4274(pushnew :asdf2 *features*)
4275
4276(provide :asdf)
4277
4278;;; Local Variables:
4279;;; mode: lisp
4280;;; End:
Note: See TracBrowser for help on using the repository browser.