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

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

asdf-2.019 with patch to get around ticket #181.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 182.5 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               ;;; XXX Kludge for ABCL ticket #181
1654               #+abcl
1655               (when (ext:pathname-jar-p pathname) 
1656                 (setf *default-pathname-defaults* 
1657                       (make-pathname :device nil :defaults *default-pathname-defaults*)))
1658               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
1659                             pathname package)
1660               (load pathname)))
1661        (delete-package package)))))
1662
1663(defun* locate-system (name)
1664  "Given a system NAME designator, try to locate where to load the system from.
1665Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
1666FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
1667FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
1668PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
1669PREVIOUS when not null is a previously loaded SYSTEM object of same name.
1670PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
1671  (let* ((name (coerce-name name))
1672         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
1673         (previous (cdr in-memory))
1674         (previous (and (typep previous 'system) previous))
1675         (previous-time (car in-memory))
1676           (found (search-for-system-definition name))
1677         (found-system (and (typep found 'system) found))
1678         (pathname (or (and (typep found '(or pathname string)) (pathname found))
1679                       (and found-system (system-source-file found-system))
1680                       (and previous (system-source-file previous))))
1681         (foundp (and (or found-system pathname previous) t)))
1682    (check-type found (or null pathname system))
1683    (when foundp
1684      (setf pathname (resolve-symlinks* pathname))
1685      (when (and pathname (not (absolute-pathname-p pathname)))
1686        (setf pathname (ensure-pathname-absolute pathname))
1687        (when found-system
1688          (%set-system-source-file pathname found-system)))
1689      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
1690                                             (system-source-file previous) pathname)))
1691        (%set-system-source-file pathname previous)
1692        (setf previous-time nil))
1693      (values foundp found-system pathname previous previous-time))))
1694
1695(defmethod find-system ((name string) &optional (error-p t))
1696  (with-system-definitions ()
1697    (loop
1698      (restart-case
1699          (multiple-value-bind (foundp found-system pathname previous previous-time)
1700              (locate-system name)
1701            (declare (ignore foundp))
1702            (when (and found-system (not previous))
1703              (register-system found-system))
1704            (when (and pathname
1705                       (or (not previous-time)
1706                           ;; don't reload if it's already been loaded,
1707                           ;; or its filestamp is in the future which means some clock is skewed
1708                           ;; and trying to load might cause an infinite loop.
1709                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
1710              (load-sysdef name pathname))
1711            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
1712              (return
1713                (cond
1714                  (in-memory
1715                   (when pathname
1716                     (setf (car in-memory) (safe-file-write-date pathname)))
1717                   (cdr in-memory))
1718                  (error-p
1719                   (error 'missing-component :requires name))))))
1720        (reinitialize-source-registry-and-retry ()
1721          :report (lambda (s)
1722                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
1723          (initialize-source-registry))))))
1724
1725(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
1726  (setf fallback (coerce-name fallback)
1727        requested (coerce-name requested))
1728  (when (equal requested fallback)
1729    (let ((registered (cdr (gethash fallback *defined-systems*))))
1730      (or registered
1731          (apply 'make-instance 'system
1732                 :name fallback :source-file source-file keys)))))
1733
1734(defun* sysdef-find-asdf (name)
1735  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
1736  (find-system-fallback name "asdf" :version *asdf-version*))
1737
1738
1739;;;; -------------------------------------------------------------------------
1740;;;; Finding components
1741
1742(defmethod find-component ((base string) path)
1743  (let ((s (find-system base nil)))
1744    (and s (find-component s path))))
1745
1746(defmethod find-component ((base symbol) path)
1747  (cond
1748    (base (find-component (coerce-name base) path))
1749    (path (find-component path nil))
1750    (t    nil)))
1751
1752(defmethod find-component ((base cons) path)
1753  (find-component (car base) (cons (cdr base) path)))
1754
1755(defmethod find-component ((module module) (name string))
1756  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
1757    (compute-module-components-by-name module))
1758  (values (gethash name (module-components-by-name module))))
1759
1760(defmethod find-component ((component component) (name symbol))
1761  (if name
1762      (find-component component (coerce-name name))
1763      component))
1764
1765(defmethod find-component ((module module) (name cons))
1766  (find-component (find-component module (car name)) (cdr name)))
1767
1768
1769;;; component subclasses
1770
1771(defclass source-file (component)
1772  ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
1773
1774(defclass cl-source-file (source-file)
1775  ((type :initform "lisp")))
1776(defclass cl-source-file.cl (cl-source-file)
1777  ((type :initform "cl")))
1778(defclass cl-source-file.lsp (cl-source-file)
1779  ((type :initform "lsp")))
1780(defclass c-source-file (source-file)
1781  ((type :initform "c")))
1782(defclass java-source-file (source-file)
1783  ((type :initform "java")))
1784(defclass static-file (source-file) ())
1785(defclass doc-file (static-file) ())
1786(defclass html-file (doc-file)
1787  ((type :initform "html")))
1788
1789(defmethod source-file-type ((component module) (s module))
1790  (declare (ignorable component s))
1791  :directory)
1792(defmethod source-file-type ((component source-file) (s module))
1793  (declare (ignorable s))
1794  (source-file-explicit-type component))
1795
1796(defun* coerce-pathname (name &key type defaults)
1797  "coerce NAME into a PATHNAME.
1798When given a string, portably decompose it into a relative pathname:
1799#\\/ separates subdirectories. The last #\\/-separated string is as follows:
1800if TYPE is NIL, its last #\\. if any separates name and type from from type;
1801if TYPE is a string, it is the type, and the whole string is the name;
1802if TYPE is :DIRECTORY, the string is a directory component;
1803if the string is empty, it's a directory.
1804Any directory named .. is read as :BACK.
1805Host, device and version components are taken from DEFAULTS."
1806  ;; The defaults are required notably because they provide the default host
1807  ;; to the below make-pathname, which may crucially matter to people using
1808  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
1809  ;; NOTE that the host and device slots will be taken from the defaults,
1810  ;; but that should only matter if you later merge relative pathnames with
1811  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
1812  (etypecase name
1813    ((or null pathname)
1814     name)
1815    (symbol
1816     (coerce-pathname (string-downcase name) :type type :defaults defaults))
1817    (string
1818     (multiple-value-bind (relative path filename)
1819         (component-name-to-pathname-components name :force-directory (eq type :directory)
1820                                                :force-relative t)
1821       (multiple-value-bind (name type)
1822           (cond
1823             ((or (eq type :directory) (null filename))
1824              (values nil nil))
1825             (type
1826              (values filename type))
1827             (t
1828              (split-name-type filename)))
1829         (apply 'make-pathname :directory (cons relative path) :name name :type type
1830                (when defaults `(:defaults ,defaults))))))))
1831
1832(defun* merge-component-name-type (name &key type defaults)
1833  ;; For backwards compatibility only, for people using internals.
1834  ;; Will be removed in a future release, e.g. 2.016.
1835  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
1836  (coerce-pathname name :type type :defaults defaults))
1837
1838(defmethod component-relative-pathname ((component component))
1839  (coerce-pathname
1840   (or (slot-value component 'relative-pathname)
1841       (component-name component))
1842   :type (source-file-type component (component-system component))
1843   :defaults (component-parent-pathname component)))
1844
1845(defun* subpathname (pathname subpath &key type)
1846  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
1847                                  (pathname-directory-pathname pathname))))
1848
1849(defun subpathname* (pathname subpath &key type)
1850  (and pathname
1851       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
1852
1853;;;; -------------------------------------------------------------------------
1854;;;; Operations
1855
1856;;; one of these is instantiated whenever #'operate is called
1857
1858(defclass operation ()
1859  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
1860   ;; T to force the inside of the specified system,
1861   ;;   but not recurse to other systems we depend on.
1862   ;; :ALL (or any other atom) to force all systems
1863   ;;   including other systems we depend on.
1864   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
1865   ;;   to force systems named in a given list
1866   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
1867   (forced :initform nil :initarg :force :accessor operation-forced)
1868   (original-initargs :initform nil :initarg :original-initargs
1869                      :accessor operation-original-initargs)
1870   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
1871   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
1872   (parent :initform nil :initarg :parent :accessor operation-parent)))
1873
1874(defmethod print-object ((o operation) stream)
1875  (print-unreadable-object (o stream :type t :identity t)
1876    (ignore-errors
1877      (prin1 (operation-original-initargs o) stream))))
1878
1879(defmethod shared-initialize :after ((operation operation) slot-names
1880                                     &key force
1881                                     &allow-other-keys)
1882  (declare (ignorable operation slot-names force))
1883  ;; empty method to disable initarg validity checking
1884  (values))
1885
1886(defun* node-for (o c)
1887  (cons (class-name (class-of o)) c))
1888
1889(defmethod operation-ancestor ((operation operation))
1890  (aif (operation-parent operation)
1891       (operation-ancestor it)
1892       operation))
1893
1894
1895(defun* make-sub-operation (c o dep-c dep-o)
1896  "C is a component, O is an operation, DEP-C is another
1897component, and DEP-O, confusingly enough, is an operation
1898class specifier, not an operation."
1899  (let* ((args (copy-list (operation-original-initargs o)))
1900         (force-p (getf args :force)))
1901    ;; note explicit comparison with T: any other non-NIL force value
1902    ;; (e.g. :recursive) will pass through
1903    (cond ((and (null (component-parent c))
1904                (null (component-parent dep-c))
1905                (not (eql c dep-c)))
1906           (when (eql force-p t)
1907             (setf (getf args :force) nil))
1908           (apply 'make-instance dep-o
1909                  :parent o
1910                  :original-initargs args args))
1911          ((subtypep (type-of o) dep-o)
1912           o)
1913          (t
1914           (apply 'make-instance dep-o
1915                  :parent o :original-initargs args args)))))
1916
1917
1918(defmethod visit-component ((o operation) (c component) data)
1919  (unless (component-visited-p o c)
1920    (setf (gethash (node-for o c)
1921                   (operation-visited-nodes (operation-ancestor o)))
1922          (cons t data))))
1923
1924(defmethod component-visited-p ((o operation) (c component))
1925  (gethash (node-for o c)
1926           (operation-visited-nodes (operation-ancestor o))))
1927
1928(defmethod (setf visiting-component) (new-value operation component)
1929  ;; MCL complains about unused lexical variables
1930  (declare (ignorable operation component))
1931  new-value)
1932
1933(defmethod (setf visiting-component) (new-value (o operation) (c component))
1934  (let ((node (node-for o c))
1935        (a (operation-ancestor o)))
1936    (if new-value
1937        (setf (gethash node (operation-visiting-nodes a)) t)
1938        (remhash node (operation-visiting-nodes a)))
1939    new-value))
1940
1941(defmethod component-visiting-p ((o operation) (c component))
1942  (let ((node (node-for o c)))
1943    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
1944
1945(defmethod component-depends-on ((op-spec symbol) (c component))
1946  ;; Note: we go from op-spec to operation via make-instance
1947  ;; to allow for specialization through defmethod's, even though
1948  ;; it's a detour in the default case below.
1949  (component-depends-on (make-instance op-spec) c))
1950
1951(defmethod component-depends-on ((o operation) (c component))
1952  (cdr (assoc (type-of o) (component-in-order-to c))))
1953
1954(defmethod component-self-dependencies ((o operation) (c component))
1955  (remove-if-not
1956   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
1957   (component-depends-on o c)))
1958
1959(defmethod input-files ((operation operation) (c component))
1960  (let ((parent (component-parent c))
1961        (self-deps (component-self-dependencies operation c)))
1962    (if self-deps
1963        (mapcan #'(lambda (dep)
1964                    (destructuring-bind (op name) dep
1965                      (output-files (make-instance op)
1966                                    (find-component parent name))))
1967                self-deps)
1968        ;; no previous operations needed?  I guess we work with the
1969        ;; original source file, then
1970        (list (component-pathname c)))))
1971
1972(defmethod input-files ((operation operation) (c module))
1973  (declare (ignorable operation c))
1974  nil)
1975
1976(defmethod component-operation-time (o c)
1977  (gethash (type-of o) (component-operation-times c)))
1978
1979(defmethod operation-done-p ((o operation) (c component))
1980  (let ((out-files (output-files o c))
1981        (in-files (input-files o c))
1982        (op-time (component-operation-time o c)))
1983    (flet ((earliest-out ()
1984             (reduce #'min (mapcar #'safe-file-write-date out-files)))
1985           (latest-in ()
1986             (reduce #'max (mapcar #'safe-file-write-date in-files))))
1987      (cond
1988        ((and (not in-files) (not out-files))
1989         ;; arbitrary decision: an operation that uses nothing to
1990         ;; produce nothing probably isn't doing much.
1991         ;; e.g. operations on systems, modules that have no immediate action,
1992         ;; but are only meaningful through traversed dependencies
1993         t)
1994        ((not out-files)
1995         ;; an operation without output-files is probably meant
1996         ;; for its side-effects in the current image,
1997         ;; assumed to be idem-potent,
1998         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
1999         (and op-time (>= op-time (latest-in))))
2000        ((not in-files)
2001         ;; an operation with output-files and no input-files
2002         ;; is probably meant for its side-effects on the file-system,
2003         ;; assumed to have to be done everytime.
2004         ;; (I don't think there is any such case in ASDF unless extended)
2005         nil)
2006        (t
2007         ;; an operation with both input and output files is assumed
2008         ;; as computing the latter from the former,
2009         ;; assumed to have been done if the latter are all older
2010         ;; than the former.
2011         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
2012         ;; We use >= instead of > to play nice with generated files.
2013         ;; This opens a race condition if an input file is changed
2014         ;; after the output is created but within the same second
2015         ;; of filesystem time; but the same race condition exists
2016         ;; whenever the computation from input to output takes more
2017         ;; than one second of filesystem time (or just crosses the
2018         ;; second). So that's cool.
2019         (and
2020          (every #'probe-file* in-files)
2021          (every #'probe-file* out-files)
2022          (>= (earliest-out) (latest-in))))))))
2023
2024
2025
2026;;; For 1.700 I've done my best to refactor TRAVERSE
2027;;; by splitting it up in a bunch of functions,
2028;;; so as to improve the collection and use-detection algorithm. --fare
2029;;; The protocol is as follows: we pass around operation, dependency,
2030;;; bunch of other stuff, and a force argument. Return a force flag.
2031;;; The returned flag is T if anything has changed that requires a rebuild.
2032;;; The force argument is a list of components that will require a rebuild
2033;;; if the flag is T, at which point whoever returns the flag has to
2034;;; mark them all as forced, and whoever recurses again can use a NIL list
2035;;; as a further argument.
2036
2037(defvar *forcing* nil
2038  "This dynamically-bound variable is used to force operations in
2039recursive calls to traverse.")
2040
2041(defgeneric* do-traverse (operation component collect))
2042
2043(defun* resolve-dependency-name (component name &optional version)
2044  (loop
2045    (restart-case
2046        (return
2047          (let ((comp (find-component (component-parent component) name)))
2048            (unless comp
2049              (error 'missing-dependency
2050                     :required-by component
2051                     :requires name))
2052            (when version
2053              (unless (version-satisfies comp version)
2054                (error 'missing-dependency-of-version
2055                       :required-by component
2056                       :version version
2057                       :requires name)))
2058            comp))
2059      (retry ()
2060        :report (lambda (s)
2061                  (format s "~@<Retry loading ~3i~_~A.~@:>" name))
2062        :test
2063        (lambda (c)
2064          (or (null c)
2065              (and (typep c 'missing-dependency)
2066                   (eq (missing-required-by c) component)
2067                   (equal (missing-requires c) name))))))))
2068
2069(defun* resolve-dependency-spec (component dep-spec)
2070  (cond
2071    ((atom dep-spec)
2072     (resolve-dependency-name component dep-spec))
2073    ;; Structured dependencies --- this parses keywords.
2074    ;; The keywords could conceivably be broken out and cleanly (extensibly)
2075    ;; processed by EQL methods. But for now, here's what we've got.
2076    ((eq :version (first dep-spec))
2077     ;; https://bugs.launchpad.net/asdf/+bug/527788
2078     (resolve-dependency-name component (second dep-spec) (third dep-spec)))
2079    ((eq :feature (first dep-spec))
2080     ;; This particular subform is not documented and
2081     ;; has always been broken in the past.
2082     ;; Therefore no one uses it, and I'm cerroring it out,
2083     ;; after fixing it
2084     ;; See https://bugs.launchpad.net/asdf/+bug/518467
2085     (cerror "Continue nonetheless."
2086             "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
2087     (when (find (second dep-spec) *features* :test 'string-equal)
2088       (resolve-dependency-name component (third dep-spec))))
2089    (t
2090     (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
2091
2092(defun* do-one-dep (op c collect dep-op dep-c)
2093  ;; Collects a partial plan for performing dep-op on dep-c
2094  ;; as dependencies of a larger plan involving op and c.
2095  ;; Returns t if this should force recompilation of those who depend on us.
2096  ;; dep-op is an operation class name (not an operation object),
2097  ;; whereas dep-c is a component object.n
2098  (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
2099
2100(defun* do-dep (op c collect dep-op-spec dep-c-specs)
2101  ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
2102  ;; as dependencies of a larger plan involving op and c.
2103  ;; Returns t if this should force recompilation of those who depend on us.
2104  ;; dep-op-spec is either an operation class name (not an operation object),
2105  ;; or the magic symbol asdf:feature.
2106  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
2107  ;; and the plan will succeed if that keyword is present in *feature*,
2108  ;; or fail if it isn't
2109  ;; (at which point c's :if-component-dep-fails will kick in).
2110  ;; If dep-op-spec is an operation class name,
2111  ;; then dep-c-specs specifies a list of sibling component of c,
2112  ;; as per resolve-dependency-spec, such that operating op on c
2113  ;; depends on operating dep-op-spec on each of them.
2114  (cond ((eq dep-op-spec 'feature)
2115         (if (member (car dep-c-specs) *features*)
2116             nil
2117             (error 'missing-dependency
2118                    :required-by c
2119                    :requires (list :feature (car dep-c-specs)))))
2120        (t
2121         (let ((flag nil))
2122           (dolist (d dep-c-specs)
2123             (when (do-one-dep op c collect dep-op-spec
2124                               (resolve-dependency-spec c d))
2125               (setf flag t)))
2126           flag))))
2127
2128(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
2129
2130(defun* do-collect (collect x)
2131  (funcall collect x))
2132
2133(defmethod do-traverse ((operation operation) (c component) collect)
2134  (let ((*forcing* *forcing*)
2135        (flag nil)) ;; return value: must we rebuild this and its dependencies?
2136    (labels
2137        ((update-flag (x)
2138           (orf flag x))
2139         (dep (op comp)
2140           (update-flag (do-dep operation c collect op comp))))
2141      ;; Have we been visited yet? If so, just process the result.
2142      (aif (component-visited-p operation c)
2143           (progn
2144             (update-flag (cdr it))
2145             (return-from do-traverse flag)))
2146      ;; dependencies
2147      (when (component-visiting-p operation c)
2148        (error 'circular-dependency :components (list c)))
2149      (setf (visiting-component operation c) t)
2150      (unwind-protect
2151           (progn
2152             (let ((f (operation-forced
2153                       (operation-ancestor operation))))
2154               (when (and f (or (not (consp f)) ;; T or :ALL
2155                                (and (typep c 'system) ;; list of names of systems to force
2156                                     (member (component-name c) f
2157                                             :test #'string=))))
2158                 (setf *forcing* t)))
2159             ;; first we check and do all the dependencies for the module.
2160             ;; Operations planned in this loop will show up
2161             ;; in the results, and are consumed below.
2162             (let ((*forcing* nil))
2163               ;; upstream dependencies are never forced to happen just because
2164               ;; the things that depend on them are....
2165               (loop
2166                 :for (required-op . deps) :in (component-depends-on operation c)
2167                 :do (dep required-op deps)))
2168             ;; constituent bits
2169             (let ((module-ops
2170                    (when (typep c 'module)
2171                      (let ((at-least-one nil)
2172                            ;; This is set based on the results of the
2173                            ;; dependencies and whether we are in the
2174                            ;; context of a *forcing* call...
2175                            ;; inter-system dependencies do NOT trigger
2176                            ;; building components
2177                            (*forcing*
2178                             (or *forcing*
2179                                 (and flag (not (typep c 'system)))))
2180                            (error nil))
2181                        (while-collecting (internal-collect)
2182                          (dolist (kid (module-components c))
2183                            (handler-case
2184                                (update-flag
2185                                 (do-traverse operation kid #'internal-collect))
2186                              #-genera
2187                              (missing-dependency (condition)
2188                                (when (eq (module-if-component-dep-fails c)
2189                                          :fail)
2190                                  (error condition))
2191                                (setf error condition))
2192                              (:no-error (c)
2193                                (declare (ignore c))
2194                                (setf at-least-one t))))
2195                          (when (and (eq (module-if-component-dep-fails c)
2196                                         :try-next)
2197                                     (not at-least-one))
2198                            (error error)))))))
2199               (update-flag (or *forcing* (not (operation-done-p operation c))))
2200                 ;; For sub-operations, check whether
2201                 ;; the original ancestor operation was forced,
2202                 ;; or names us amongst an explicit list of things to force...
2203                 ;; except that this check doesn't distinguish
2204                 ;; between all the things with a given name. Sigh.
2205                 ;; BROKEN!
2206               (when flag
2207                 (let ((do-first (cdr (assoc (class-name (class-of operation))
2208                                             (component-do-first c)))))
2209                   (loop :for (required-op . deps) :in do-first
2210                     :do (do-dep operation c collect required-op deps)))
2211                 (do-collect collect (vector module-ops))
2212                 (do-collect collect (cons operation c)))))
2213             (setf (visiting-component operation c) nil)))
2214      (visit-component operation c (when flag (incf *visit-count*)))
2215      flag))
2216
2217(defun* flatten-tree (l)
2218  ;; You collected things into a list.
2219  ;; Most elements are just things to collect again.
2220  ;; A (simple-vector 1) indicate that you should recurse into its contents.
2221  ;; This way, in two passes (rather than N being the depth of the tree),
2222  ;; you can collect things with marginally constant-time append,
2223  ;; achieving linear time collection instead of quadratic time.
2224  (while-collecting (c)
2225    (labels ((r (x)
2226               (if (typep x '(simple-vector 1))
2227                   (r* (svref x 0))
2228                   (c x)))
2229             (r* (l)
2230               (dolist (x l) (r x))))
2231      (r* l))))
2232
2233(defmethod traverse ((operation operation) (c component))
2234  (when (consp (operation-forced operation))
2235    (setf (operation-forced operation)
2236          (mapcar #'coerce-name (operation-forced operation))))
2237  (flatten-tree
2238   (while-collecting (collect)
2239     (let ((*visit-count* 0))
2240       (do-traverse operation c #'collect)))))
2241
2242(defmethod perform ((operation operation) (c source-file))
2243  (sysdef-error
2244   (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
2245   (class-of operation) (class-of c)))
2246
2247(defmethod perform ((operation operation) (c module))
2248  (declare (ignorable operation c))
2249  nil)
2250
2251(defmethod mark-operation-done ((operation operation) (c component))
2252  (setf (gethash (type-of operation) (component-operation-times c))
2253    (reduce #'max
2254            (cons (get-universal-time)
2255                  (mapcar #'safe-file-write-date (input-files operation c))))))
2256
2257(defmethod perform-with-restarts (operation component)
2258  ;; TOO verbose, especially as the default. Add your own :before method
2259  ;; to perform-with-restart or perform if you want that:
2260  #|(when *asdf-verbose* (explain operation component))|#
2261  (perform operation component))
2262
2263(defmethod perform-with-restarts :around (operation component)
2264  (loop
2265    (restart-case
2266        (return (call-next-method))
2267      (retry ()
2268        :report
2269        (lambda (s)
2270          (format s (compatfmt "~@<Retry ~A.~@:>")
2271                  (operation-description operation component))))
2272      (accept ()
2273        :report
2274        (lambda (s)
2275          (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
2276                  (operation-description operation component)))
2277        (mark-operation-done operation component)
2278        (return)))))
2279
2280(defmethod explain ((operation operation) (component component))
2281  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
2282                (operation-description operation component)))
2283
2284(defmethod operation-description (operation component)
2285  (format nil (compatfmt "~@<~A on ~A~@:>")
2286          (class-of operation) component))
2287
2288;;;; -------------------------------------------------------------------------
2289;;;; compile-op
2290
2291(defclass compile-op (operation)
2292  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
2293   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
2294                :initform *compile-file-warnings-behaviour*)
2295   (on-failure :initarg :on-failure :accessor operation-on-failure
2296               :initform *compile-file-failure-behaviour*)
2297   (flags :initarg :flags :accessor compile-op-flags
2298          :initform nil)))
2299
2300(defun* output-file (operation component)
2301  "The unique output file of performing OPERATION on COMPONENT"
2302  (let ((files (output-files operation component)))
2303    (assert (length=n-p files 1))
2304    (first files)))
2305
2306(defun* ensure-all-directories-exist (pathnames)
2307   (loop :for pn :in pathnames
2308     :for pathname = (if (typep pn 'logical-pathname)
2309                         (translate-logical-pathname pn)
2310                         pn)
2311     :do (ensure-directories-exist pathname)))
2312
2313(defmethod perform :before ((operation compile-op) (c source-file))
2314  (ensure-all-directories-exist (asdf:output-files operation c)))
2315
2316(defmethod perform :after ((operation operation) (c component))
2317  (mark-operation-done operation c))
2318
2319(defgeneric* around-compile-hook (component))
2320(defgeneric* call-with-around-compile-hook (component thunk))
2321
2322(defmethod around-compile-hook ((c component))
2323  (cond
2324    ((slot-boundp c 'around-compile)
2325     (slot-value c 'around-compile))
2326    ((component-parent c)
2327     (around-compile-hook (component-parent c)))))
2328
2329(defun ensure-function (fun &key (package :asdf))
2330  (etypecase fun
2331    ((or symbol function) fun)
2332    (cons (eval `(function ,fun)))
2333    (string (eval `(function ,(with-standard-io-syntax
2334                               (let ((*package* (find-package package)))
2335                                 (read-from-string fun))))))))
2336
2337(defmethod call-with-around-compile-hook ((c component) thunk)
2338  (let ((hook (around-compile-hook c)))
2339    (if hook
2340        (funcall (ensure-function hook) thunk)
2341        (funcall thunk))))
2342
2343(defvar *compile-op-compile-file-function* 'compile-file*
2344  "Function used to compile lisp files.")
2345
2346;;; perform is required to check output-files to find out where to put
2347;;; its answers, in case it has been overridden for site policy
2348(defmethod perform ((operation compile-op) (c cl-source-file))
2349  #-:broken-fasl-loader
2350  (let ((source-file (component-pathname c))
2351        ;; on some implementations, there are more than one output-file,
2352        ;; but the first one should always be the primary fasl that gets loaded.
2353        (output-file (first (output-files operation c)))
2354        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
2355        (*compile-file-failure-behaviour* (operation-on-failure operation)))
2356    (multiple-value-bind (output warnings-p failure-p)
2357        (call-with-around-compile-hook
2358         c #'(lambda ()
2359               (apply *compile-op-compile-file-function* source-file
2360                      :output-file output-file (compile-op-flags operation))))
2361      (unless output
2362        (error 'compile-error :component c :operation operation))
2363      (when failure-p
2364        (case (operation-on-failure operation)
2365          (:warn (warn
2366                  (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
2367                  operation c))
2368          (:error (error 'compile-failed :component c :operation operation))
2369          (:ignore nil)))
2370      (when warnings-p
2371        (case (operation-on-warnings operation)
2372          (:warn (warn
2373                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
2374                  operation c))
2375          (:error (error 'compile-warned :component c :operation operation))
2376          (:ignore nil))))))
2377
2378(defmethod output-files ((operation compile-op) (c cl-source-file))
2379  (declare (ignorable operation))
2380  (let ((p (lispize-pathname (component-pathname c))))
2381    #-broken-fasl-loader (list (compile-file-pathname p))
2382    #+broken-fasl-loader (list p)))
2383
2384(defmethod perform ((operation compile-op) (c static-file))
2385  (declare (ignorable operation c))
2386  nil)
2387
2388(defmethod output-files ((operation compile-op) (c static-file))
2389  (declare (ignorable operation c))
2390  nil)
2391
2392(defmethod input-files ((operation compile-op) (c static-file))
2393  (declare (ignorable operation c))
2394  nil)
2395
2396(defmethod operation-description ((operation compile-op) component)
2397  (declare (ignorable operation))
2398  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
2399
2400(defmethod operation-description ((operation compile-op) (component module))
2401  (declare (ignorable operation))
2402  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
2403
2404
2405;;;; -------------------------------------------------------------------------
2406;;;; load-op
2407
2408(defclass basic-load-op (operation) ())
2409
2410(defclass load-op (basic-load-op) ())
2411
2412(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
2413  (loop
2414    (restart-case
2415        (return (call-next-method))
2416      (try-recompiling ()
2417        :report (lambda (s)
2418                  (format s "Recompile ~a and try loading it again"
2419                          (component-name c)))
2420        (perform (make-sub-operation c o c 'compile-op) c)))))
2421
2422(defmethod perform ((o load-op) (c cl-source-file))
2423  (map () #'load (input-files o c)))
2424
2425(defmethod perform ((operation load-op) (c static-file))
2426  (declare (ignorable operation c))
2427  nil)
2428
2429(defmethod operation-done-p ((operation load-op) (c static-file))
2430  (declare (ignorable operation c))
2431  t)
2432
2433(defmethod output-files ((operation operation) (c component))
2434  (declare (ignorable operation c))
2435  nil)
2436
2437(defmethod component-depends-on ((operation load-op) (c component))
2438  (declare (ignorable operation))
2439  (cons (list 'compile-op (component-name c))
2440        (call-next-method)))
2441
2442(defmethod operation-description ((operation load-op) component)
2443  (declare (ignorable operation))
2444  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
2445          component))
2446
2447(defmethod operation-description ((operation load-op) (component cl-source-file))
2448  (declare (ignorable operation))
2449  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
2450          component))
2451
2452(defmethod operation-description ((operation load-op) (component module))
2453  (declare (ignorable operation))
2454  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
2455          component))
2456
2457;;;; -------------------------------------------------------------------------
2458;;;; load-source-op
2459
2460(defclass load-source-op (basic-load-op) ())
2461
2462(defmethod perform ((o load-source-op) (c cl-source-file))
2463  (declare (ignorable o))
2464  (let ((source (component-pathname c)))
2465    (setf (component-property c 'last-loaded-as-source)
2466          (and (call-with-around-compile-hook c #'(lambda () (load source)))
2467               (get-universal-time)))))
2468
2469(defmethod perform ((operation load-source-op) (c static-file))
2470  (declare (ignorable operation c))
2471  nil)
2472
2473(defmethod output-files ((operation load-source-op) (c component))
2474  (declare (ignorable operation c))
2475  nil)
2476
2477;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
2478(defmethod component-depends-on ((o load-source-op) (c component))
2479  (declare (ignorable o))
2480  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
2481    :for (op . co) :in what-would-load-op-do
2482    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
2483
2484(defmethod operation-done-p ((o load-source-op) (c source-file))
2485  (declare (ignorable o))
2486  (if (or (not (component-property c 'last-loaded-as-source))
2487          (> (safe-file-write-date (component-pathname c))
2488             (component-property c 'last-loaded-as-source)))
2489      nil t))
2490
2491(defmethod operation-description ((operation load-source-op) component)
2492  (declare (ignorable operation))
2493  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
2494          component))
2495
2496(defmethod operation-description ((operation load-source-op) (component module))
2497  (declare (ignorable operation))
2498  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
2499
2500
2501;;;; -------------------------------------------------------------------------
2502;;;; test-op
2503
2504(defclass test-op (operation) ())
2505
2506(defmethod perform ((operation test-op) (c component))
2507  (declare (ignorable operation c))
2508  nil)
2509
2510(defmethod operation-done-p ((operation test-op) (c system))
2511  "Testing a system is _never_ done."
2512  (declare (ignorable operation c))
2513  nil)
2514
2515(defmethod component-depends-on :around ((o test-op) (c system))
2516  (declare (ignorable o))
2517  (cons `(load-op ,(component-name c)) (call-next-method)))
2518
2519
2520;;;; -------------------------------------------------------------------------
2521;;;; Invoking Operations
2522
2523(defgeneric* operate (operation-class system &key &allow-other-keys))
2524(defgeneric* perform-plan (plan &key))
2525
2526;;;; Separating this into a different function makes it more forward-compatible
2527(defun* cleanup-upgraded-asdf (old-version)
2528  (let ((new-version (asdf:asdf-version)))
2529    (unless (equal old-version new-version)
2530      (cond
2531        ((version-satisfies new-version old-version)
2532         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
2533                       old-version new-version))
2534        ((version-satisfies old-version new-version)
2535         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
2536               old-version new-version))
2537        (t
2538         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
2539                       old-version new-version)))
2540      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
2541        ;; Invalidate all systems but ASDF itself.
2542        (setf *defined-systems* (make-defined-systems-table))
2543        (register-system asdf)
2544        ;; If we're in the middle of something, restart it.
2545        (when *systems-being-defined*
2546          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
2547            (clrhash *systems-being-defined*)
2548            (dolist (s l) (find-system s nil))))
2549        t))))
2550
2551;;;; Try to upgrade of ASDF. If a different version was used, return T.
2552;;;; We need do that before we operate on anything that depends on ASDF.
2553(defun* upgrade-asdf ()
2554  (let ((version (asdf:asdf-version)))
2555    (handler-bind (((or style-warning warning) #'muffle-warning))
2556      (operate 'load-op :asdf :verbose nil))
2557    (cleanup-upgraded-asdf version)))
2558
2559(defmethod perform-plan ((steps list) &key)
2560  (let ((*package* *package*)
2561        (*readtable* *readtable*))
2562    (with-compilation-unit ()
2563      (loop :for (op . component) :in steps :do
2564        (perform-with-restarts op component)))))
2565
2566(defmethod operate (operation-class system &rest args
2567                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
2568                    &allow-other-keys)
2569  (declare (ignore force))
2570  (with-system-definitions ()
2571    (let* ((op (apply 'make-instance operation-class
2572                      :original-initargs args
2573                      args))
2574           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
2575           (system (etypecase system
2576                     (system system)
2577                     ((or string symbol) (find-system system)))))
2578      (unless (version-satisfies system version)
2579        (error 'missing-component-of-version :requires system :version version))
2580      (let ((steps (traverse op system)))
2581        (when (and (not (equal '("asdf") (component-find-path system)))
2582                   (find '("asdf") (mapcar 'cdr steps)
2583                         :test 'equal :key 'component-find-path)
2584                   (upgrade-asdf))
2585          ;; If we needed to upgrade ASDF to achieve our goal,
2586          ;; then do it specially as the first thing, then
2587          ;; invalidate all existing system
2588          ;; retry the whole thing with the new OPERATE function,
2589          ;; which on some implementations
2590          ;; has a new symbol shadowing the current one.
2591          (return-from operate
2592            (apply (find-symbol* 'operate :asdf) operation-class system args)))
2593        (perform-plan steps)
2594        (values op steps)))))
2595
2596(defun* oos (operation-class system &rest args &key force verbose version
2597            &allow-other-keys)
2598  (declare (ignore force verbose version))
2599  (apply 'operate operation-class system args))
2600
2601(let ((operate-docstring
2602  "Operate does three things:
2603
26041. It creates an instance of OPERATION-CLASS using any keyword parameters
2605as initargs.
26062. It finds the  asdf-system specified by SYSTEM (possibly loading
2607it from disk).
26083. It then calls TRAVERSE with the operation and system as arguments
2609
2610The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
2611handling code. If a VERSION argument is supplied, then operate also
2612ensures that the system found satisfies it using the VERSION-SATISFIES
2613method.
2614
2615Note that dependencies may cause the operation to invoke other
2616operations on the system or its components: the new operations will be
2617created with the same initargs as the original one.
2618"))
2619  (setf (documentation 'oos 'function)
2620        (format nil
2621                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
2622                operate-docstring))
2623  (setf (documentation 'operate 'function)
2624        operate-docstring))
2625
2626(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
2627  "Shorthand for `(operate 'asdf:load-op system)`.
2628See OPERATE for details."
2629  (declare (ignore force verbose version))
2630  (apply 'operate 'load-op system args)
2631  t)
2632
2633(defun* load-systems (&rest systems)
2634  (map () 'load-system systems))
2635
2636(defun* compile-system (system &rest args &key force verbose version
2637                       &allow-other-keys)
2638  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
2639for details."
2640  (declare (ignore force verbose version))
2641  (apply 'operate 'compile-op system args)
2642  t)
2643
2644(defun* test-system (system &rest args &key force verbose version
2645                    &allow-other-keys)
2646  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
2647details."
2648  (declare (ignore force verbose version))
2649  (apply 'operate 'test-op system args)
2650  t)
2651
2652;;;; -------------------------------------------------------------------------
2653;;;; Defsystem
2654
2655(defun* load-pathname ()
2656  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
2657
2658(defun* determine-system-pathname (pathname)
2659  ;; The defsystem macro calls us to determine
2660  ;; the pathname of a system as follows:
2661  ;; 1. the one supplied,
2662  ;; 2. derived from *load-pathname* via load-pathname
2663  ;; 3. taken from the *default-pathname-defaults* via default-directory
2664  (let* ((file-pathname (load-pathname))
2665         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
2666    (or (and pathname (subpathname directory-pathname pathname :type :directory))
2667        directory-pathname
2668        (default-directory))))
2669
2670(defun* class-for-type (parent type)
2671  (or (loop :for symbol :in (list
2672                             type
2673                             (find-symbol* type *package*)
2674                             (find-symbol* type :asdf))
2675        :for class = (and symbol (find-class symbol nil))
2676        :when (and class
2677                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
2678                                 class (find-class 'component)))
2679        :return class)
2680      (and (eq type :file)
2681           (or (and parent (module-default-component-class parent))
2682               (find-class *default-component-class*)))
2683      (sysdef-error "don't recognize component type ~A" type)))
2684
2685(defun* maybe-add-tree (tree op1 op2 c)
2686  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
2687Returns the new tree (which probably shares structure with the old one)"
2688  (let ((first-op-tree (assoc op1 tree)))
2689    (if first-op-tree
2690        (progn
2691          (aif (assoc op2 (cdr first-op-tree))
2692               (if (find c (cdr it) :test #'equal)
2693                   nil
2694                   (setf (cdr it) (cons c (cdr it))))
2695               (setf (cdr first-op-tree)
2696                     (acons op2 (list c) (cdr first-op-tree))))
2697          tree)
2698        (acons op1 (list (list op2 c)) tree))))
2699
2700(defun* union-of-dependencies (&rest deps)
2701  (let ((new-tree nil))
2702    (dolist (dep deps)
2703      (dolist (op-tree dep)
2704        (dolist (op  (cdr op-tree))
2705          (dolist (c (cdr op))
2706            (setf new-tree
2707                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
2708    new-tree))
2709
2710
2711(defvar *serial-depends-on* nil)
2712
2713(defun* sysdef-error-component (msg type name value)
2714  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
2715                type name value))
2716
2717(defun* check-component-input (type name weakly-depends-on
2718                              depends-on components in-order-to)
2719  "A partial test of the values of a component."
2720  (unless (listp depends-on)
2721    (sysdef-error-component ":depends-on must be a list."
2722                            type name depends-on))
2723  (unless (listp weakly-depends-on)
2724    (sysdef-error-component ":weakly-depends-on must be a list."
2725                            type name weakly-depends-on))
2726  (unless (listp components)
2727    (sysdef-error-component ":components must be NIL or a list of components."
2728                            type name components))
2729  (unless (and (listp in-order-to) (listp (car in-order-to)))
2730    (sysdef-error-component ":in-order-to must be NIL or a list of components."
2731                            type name in-order-to)))
2732
2733(defun* %remove-component-inline-methods (component)
2734  (dolist (name +asdf-methods+)
2735    (map ()
2736         ;; this is inefficient as most of the stored
2737         ;; methods will not be for this particular gf
2738         ;; But this is hardly performance-critical
2739         #'(lambda (m)
2740             (remove-method (symbol-function name) m))
2741         (component-inline-methods component)))
2742  ;; clear methods, then add the new ones
2743  (setf (component-inline-methods component) nil))
2744
2745(defun* %define-component-inline-methods (ret rest)
2746  (dolist (name +asdf-methods+)
2747    (let ((keyword (intern (symbol-name name) :keyword)))
2748      (loop :for data = rest :then (cddr data)
2749        :for key = (first data)
2750        :for value = (second data)
2751        :while data
2752        :when (eq key keyword) :do
2753        (destructuring-bind (op qual (o c) &body body) value
2754          (pushnew
2755           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
2756                             ,@body))
2757           (component-inline-methods ret)))))))
2758
2759(defun* %refresh-component-inline-methods (component rest)
2760  (%remove-component-inline-methods component)
2761  (%define-component-inline-methods component rest))
2762
2763(defun* parse-component-form (parent options)
2764  (destructuring-bind
2765        (type name &rest rest &key
2766              ;; the following list of keywords is reproduced below in the
2767              ;; remove-keys form.  important to keep them in sync
2768              components pathname default-component-class
2769              perform explain output-files operation-done-p
2770              weakly-depends-on
2771              depends-on serial in-order-to do-first
2772              (version nil versionp)
2773              ;; list ends
2774              &allow-other-keys) options
2775    (declare (ignorable perform explain output-files operation-done-p))
2776    (check-component-input type name weakly-depends-on depends-on components in-order-to)
2777
2778    (when (and parent
2779               (find-component parent name)
2780               ;; ignore the same object when rereading the defsystem
2781               (not
2782                (typep (find-component parent name)
2783                       (class-for-type parent type))))
2784      (error 'duplicate-names :name name))
2785
2786    (when versionp
2787      (unless (parse-version version nil)
2788        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
2789              version name parent)))
2790
2791    (let* ((args (list* :name (coerce-name name)
2792                        :pathname pathname
2793                        :parent parent
2794                        (remove-keys
2795                         '(components pathname default-component-class
2796                           perform explain output-files operation-done-p
2797                           weakly-depends-on depends-on serial in-order-to)
2798                         rest)))
2799           (ret (find-component parent name)))
2800      (when weakly-depends-on
2801        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
2802      (when *serial-depends-on*
2803        (push *serial-depends-on* depends-on))
2804      (if ret ; preserve identity
2805          (apply 'reinitialize-instance ret args)
2806          (setf ret (apply 'make-instance (class-for-type parent type) args)))
2807      (component-pathname ret) ; eagerly compute the absolute pathname
2808      (when (typep ret 'module)
2809        (setf (module-default-component-class ret)
2810              (or default-component-class
2811                  (and (typep parent 'module)
2812                       (module-default-component-class parent))))
2813        (let ((*serial-depends-on* nil))
2814          (setf (module-components ret)
2815                (loop
2816                  :for c-form :in components
2817                  :for c = (parse-component-form ret c-form)
2818                  :for name = (component-name c)
2819                  :collect c
2820                  :when serial :do (setf *serial-depends-on* name))))
2821        (compute-module-components-by-name ret))
2822
2823      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
2824
2825      (setf (component-in-order-to ret)
2826            (union-of-dependencies
2827             in-order-to
2828             `((compile-op (compile-op ,@depends-on))
2829               (load-op (load-op ,@depends-on)))))
2830      (setf (component-do-first ret)
2831            (union-of-dependencies
2832             do-first
2833             `((compile-op (load-op ,@depends-on)))))
2834
2835      (%refresh-component-inline-methods ret rest)
2836      ret)))
2837
2838(defun* reset-system (system &rest keys &key &allow-other-keys)
2839  (change-class (change-class system 'proto-system) 'system)
2840  (apply 'reinitialize-instance system keys))
2841
2842(defun* do-defsystem (name &rest options
2843                           &key pathname (class 'system)
2844                           defsystem-depends-on &allow-other-keys)
2845  ;; The system must be registered before we parse the body,
2846  ;; otherwise we recur when trying to find an existing system
2847  ;; of the same name to reuse options (e.g. pathname) from.
2848  ;; To avoid infinite recursion in cases where you defsystem a system
2849  ;; that is registered to a different location to find-system,
2850  ;; we also need to remember it in a special variable *systems-being-defined*.
2851  (with-system-definitions ()
2852    (let* ((name (coerce-name name))
2853           (registered (system-registered-p name))
2854           (registered! (if registered
2855                            (rplaca registered (get-universal-time))
2856                            (register-system (make-instance 'system :name name))))
2857           (system (reset-system (cdr registered!)
2858                                :name name :source-file (load-pathname)))
2859           (component-options (remove-keys '(:class) options)))
2860      (setf (gethash name *systems-being-defined*) system)
2861      (apply 'load-systems defsystem-depends-on)
2862      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
2863      ;; since the class might not be defined as part of those.
2864      (let ((class (class-for-type nil class)))
2865        (unless (eq (type-of system) class)
2866          (change-class system class)))
2867      (parse-component-form
2868       nil (list*
2869            :module name
2870            :pathname (determine-system-pathname pathname)
2871            component-options)))))
2872
2873(defmacro defsystem (name &body options)
2874  `(apply 'do-defsystem ',name ',options))
2875
2876;;;; ---------------------------------------------------------------------------
2877;;;; run-shell-command
2878;;;;
2879;;;; run-shell-command functions for other lisp implementations will be
2880;;;; gratefully accepted, if they do the same thing.
2881;;;; If the docstring is ambiguous, send a bug report.
2882;;;;
2883;;;; WARNING! The function below is mostly dysfunctional.
2884;;;; For instance, it will probably run fine on most implementations on Unix,
2885;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
2886;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
2887;;;; But behavior on Windows may vary wildly between implementations,
2888;;;; either relying on your having installed a POSIX sh, or going through
2889;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
2890;;;; what is easily expressible in said implementation.
2891;;;;
2892;;;; We probably should move this functionality to its own system and deprecate
2893;;;; use of it from the asdf package. However, this would break unspecified
2894;;;; existing software, so until a clear alternative exists, we can't deprecate
2895;;;; it, and even after it's been deprecated, we will support it for a few
2896;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
2897;;;;
2898;;;; As a suggested replacement which is portable to all ASDF-supported
2899;;;; implementations and operating systems except Genera, I recommend
2900;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its
2901;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
2902
2903(defun* run-shell-command (control-string &rest args)
2904  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
2905synchronously execute the result using a Bourne-compatible shell, with
2906output to *VERBOSE-OUT*.  Returns the shell's exit code."
2907  (let ((command (apply 'format nil control-string args)))
2908    (asdf-message "; $ ~A~%" command)
2909
2910    #+abcl
2911    (ext:run-shell-command command :output *verbose-out*)
2912
2913    #+allegro
2914    ;; will this fail if command has embedded quotes - it seems to work
2915    (multiple-value-bind (stdout stderr exit-code)
2916        (excl.osi:command-output
2917         #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
2918         #+mswindows command ; BEWARE!
2919         :input nil :whole nil
2920         #+mswindows :show-window #+mswindows :hide)
2921      (asdf-message "~{~&~a~%~}~%" stderr)
2922      (asdf-message "~{~&~a~%~}~%" stdout)
2923      exit-code)
2924
2925    #+clisp
2926    ;; CLISP returns NIL for exit status zero.
2927    (if *verbose-out*
2928        (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
2929                                    command))
2930               (outstream (ext:run-shell-command new-command :output :stream :wait t)))
2931            (multiple-value-bind (retval out-lines)
2932                (unwind-protect
2933                     (parse-clisp-shell-output outstream)
2934                  (ignore-errors (close outstream)))
2935              (asdf-message "~{~&~a~%~}~%" out-lines)
2936              retval))
2937        ;; there will be no output, just grab up the exit status
2938        (or (ext:run-shell-command command :output nil :wait t) 0))
2939
2940    #+clozure
2941    (nth-value 1
2942               (ccl:external-process-status
2943                (ccl:run-program
2944                 (cond
2945                   ((os-unix-p) "/bin/sh")
2946                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
2947                   (t (error "Unsupported OS")))
2948                 (if (os-unix-p) (list "-c" command) '())
2949                 :input nil :output *verbose-out* :wait t)))
2950
2951    #+(or cmu scl)
2952    (ext:process-exit-code
2953     (ext:run-program
2954      "/bin/sh"
2955      (list "-c" command)
2956      :input nil :output *verbose-out*))
2957
2958    #+cormanlisp
2959    (win32:system command)
2960
2961    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
2962    (ext:system command)
2963
2964    #+gcl
2965    (lisp:system command)
2966
2967    #+lispworks
2968    (apply 'system:call-system-showing-output command
2969           :show-cmd nil :prefix "" :output-stream *verbose-out*
2970           (when (os-unix-p) '(:shell-type "/bin/sh")))
2971
2972    #+mcl
2973    (ccl::with-cstrs ((%command command)) (_system %command))
2974
2975    #+sbcl
2976    (sb-ext:process-exit-code
2977     (apply 'sb-ext:run-program
2978            #+win32 "sh" #-win32 "/bin/sh"
2979            (list  "-c" command)
2980            :input nil :output *verbose-out*
2981            #+win32 '(:search t) #-win32 nil))
2982
2983    #+xcl
2984    (ext:run-shell-command command)
2985
2986    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
2987    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
2988
2989#+clisp
2990(defun* parse-clisp-shell-output (stream)
2991  "Helper function for running shell commands under clisp.  Parses a specially-
2992crafted output string to recover the exit status of the shell command and a
2993list of lines of output."
2994  (loop :with status-prefix = "ASDF-EXIT-STATUS "
2995    :with prefix-length = (length status-prefix)
2996    :with exit-status = -1 :with lines = ()
2997    :for line = (read-line stream nil nil)
2998    :while line :do (push line lines) :finally
2999    (let* ((last (car lines))
3000           (status (and last (>= (length last) prefix-length)
3001                        (string-equal last status-prefix :end1 prefix-length)
3002                        (parse-integer last :start prefix-length :junk-allowed t))))
3003      (when status
3004        (setf exit-status status)
3005        (pop lines) (when (equal "" (car lines)) (pop lines)))
3006      (return (values exit-status (reverse lines))))))
3007
3008;;;; ---------------------------------------------------------------------------
3009;;;; system-relative-pathname
3010
3011(defun* system-definition-pathname (x)
3012  ;; As of 2.014.8, we mean to make this function obsolete,
3013  ;; but that won't happen until all clients have been updated.
3014  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
3015  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
3016It used to expose ASDF internals with subtle differences with respect to
3017user expectations, that have been refactored away since.
3018We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
3019for a mostly compatible replacement that we're supporting,
3020or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
3021if that's whay you mean." ;;)
3022  (system-source-file x))
3023
3024(defmethod system-source-file ((system system))
3025  (%system-source-file system))
3026(defmethod system-source-file ((system-name string))
3027  (%system-source-file (find-system system-name)))
3028(defmethod system-source-file ((system-name symbol))
3029  (%system-source-file (find-system system-name)))
3030
3031(defun* system-source-directory (system-designator)
3032  "Return a pathname object corresponding to the
3033directory in which the system specification (.asd file) is
3034located."
3035  (pathname-directory-pathname (system-source-file system-designator)))
3036
3037(defun* relativize-directory (directory)
3038  (cond
3039    ((stringp directory)
3040     (list :relative directory))
3041    ((eq (car directory) :absolute)
3042     (cons :relative (cdr directory)))
3043    (t
3044     directory)))
3045
3046(defun* relativize-pathname-directory (pathspec)
3047  (let ((p (pathname pathspec)))
3048    (make-pathname
3049     :directory (relativize-directory (pathname-directory p))
3050     :defaults p)))
3051
3052(defun* system-relative-pathname (system name &key type)
3053  (subpathname (system-source-directory system) name :type type))
3054
3055
3056;;; ---------------------------------------------------------------------------
3057;;; implementation-identifier
3058;;;
3059;;; produce a string to identify current implementation.
3060;;; Initially stolen from SLIME's SWANK, rewritten since.
3061;;; We're back to runtime checking, for the sake of e.g. ABCL.
3062
3063(defun* first-feature (features)
3064  (dolist (x features)
3065    (multiple-value-bind (val feature)
3066        (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
3067      (when (featurep feature) (return val)))))
3068
3069(defun implementation-type ()
3070  (first-feature
3071   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
3072     :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
3073
3074(defun operating-system ()
3075  (first-feature
3076   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
3077     (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
3078     (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
3079     (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
3080     :genera)))
3081
3082(defun architecture ()
3083  (first-feature
3084   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
3085     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
3086     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
3087     :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
3088     :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
3089     ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
3090     ;; we may have to segregate the code still by architecture.
3091     (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
3092
3093(defun lisp-version-string ()
3094  (let ((s (lisp-implementation-version)))
3095    (car ; as opposed to OR, this idiom prevents some unreachable code warning
3096     (list
3097      #+allegro
3098      (format nil "~A~A~@[~A~]"
3099              excl::*common-lisp-version-number*
3100              ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
3101              (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
3102              ;; Note if not using International ACL
3103              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
3104              (excl:ics-target-case (:-ics "8")))
3105      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
3106      #+clisp
3107      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
3108      #+clozure
3109      (format nil "~d.~d-f~d" ; shorten for windows
3110              ccl::*openmcl-major-version*
3111              ccl::*openmcl-minor-version*
3112              (logand ccl::fasl-version #xFF))
3113      #+cmu (substitute #\- #\/ s)
3114      #+scl (format nil "~A~A" s
3115        ;; ANSI upper case vs lower case.
3116        (ecase ext:*case-mode* (:upper "") (:lower "l")))
3117      #+ecl (format nil "~A~@[-~A~]" s
3118                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
3119                      (subseq vcs-id 0 (min (length vcs-id) 8))))
3120      #+gcl (subseq s (1+ (position #\space s)))
3121      #+genera
3122      (multiple-value-bind (major minor) (sct:get-system-version "System")
3123        (format nil "~D.~D" major minor))
3124      #+mcl (subseq s 8) ; strip the leading "Version "
3125      s))))
3126
3127(defun* implementation-identifier ()
3128  (substitute-if
3129   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
3130   (format nil "~(~a~@{~@[-~a~]~}~)"
3131           (or (implementation-type) (lisp-implementation-type))
3132           (or (lisp-version-string) (lisp-implementation-version))
3133           (or (operating-system) (software-type))
3134           (or (architecture) (machine-type)))))
3135
3136
3137;;; ---------------------------------------------------------------------------
3138;;; Generic support for configuration files
3139
3140(defun inter-directory-separator ()
3141  (if (os-unix-p) #\: #\;))
3142
3143(defun* user-homedir ()
3144  (truenamize
3145   (pathname-directory-pathname
3146    #+mcl (current-user-homedir-pathname)
3147    #-mcl (user-homedir-pathname))))
3148
3149(defun* user-configuration-directories ()
3150  (let ((dirs
3151         `(,@(when (os-unix-p)
3152               (cons
3153                (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/")
3154                (loop :with dirs = (getenv "XDG_CONFIG_DIRS")
3155                  :for dir :in (split-string dirs :separator ":")
3156                  :collect (subpathname* dir "common-lisp/"))))
3157           ,@(when (os-windows-p)
3158               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
3159                                    (getenv "LOCALAPPDATA"))
3160                               "common-lisp/config/")
3161                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
3162                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
3163                                    (getenv "APPDATA"))
3164                                "common-lisp/config/")))
3165           ,(subpathname (user-homedir) ".config/common-lisp/"))))
3166    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
3167                       :from-end t :test 'equal)))
3168
3169(defun* system-configuration-directories ()
3170  (cond
3171    ((os-unix-p) '(#p"/etc/common-lisp/"))
3172    ((os-windows-p)
3173     (aif
3174      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
3175      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
3176                        (getenv "ALLUSERSAPPDATA")
3177                        (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))
3178                    "common-lisp/config/")
3179      (list it)))))
3180
3181(defun* in-first-directory (dirs x &key (direction :input))
3182  (loop :with fun = (ecase direction
3183                      ((nil :input :probe) 'probe-file*)
3184                      ((:output :io) 'identity))
3185    :for dir :in dirs
3186    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
3187
3188(defun* in-user-configuration-directory (x &key (direction :input))
3189  (in-first-directory (user-configuration-directories) x :direction direction))
3190(defun* in-system-configuration-directory (x &key (direction :input))
3191  (in-first-directory (system-configuration-directories) x :direction direction))
3192
3193(defun* configuration-inheritance-directive-p (x)
3194  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
3195    (or (member x kw)
3196        (and (length=n-p x 1) (member (car x) kw)))))
3197
3198(defun* report-invalid-form (reporter &rest args)
3199  (etypecase reporter
3200    (null
3201     (apply 'error 'invalid-configuration args))
3202    (function
3203     (apply reporter args))
3204    ((or symbol string)
3205     (apply 'error reporter args))
3206    (cons
3207     (apply 'apply (append reporter args)))))
3208
3209(defvar *ignored-configuration-form* nil)
3210
3211(defun* validate-configuration-form (form tag directive-validator
3212                                    &key location invalid-form-reporter)
3213  (unless (and (consp form) (eq (car form) tag))
3214    (setf *ignored-configuration-form* t)
3215    (report-invalid-form invalid-form-reporter :form form :location location)
3216    (return-from validate-configuration-form nil))
3217  (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
3218    :for directive :in (cdr form)
3219    :when (cond
3220            ((configuration-inheritance-directive-p directive)
3221             (incf inherit) t)
3222            ((eq directive :ignore-invalid-entries)
3223             (setf ignore-invalid-p t) t)
3224            ((funcall directive-validator directive)
3225             t)
3226            (ignore-invalid-p
3227             nil)
3228            (t
3229             (setf *ignored-configuration-form* t)
3230             (report-invalid-form invalid-form-reporter :form directive :location location)
3231             nil))
3232    :do (push directive x)
3233    :finally
3234    (unless (= inherit 1)
3235      (report-invalid-form invalid-form-reporter
3236             :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
3237                              :inherit-configuration :ignore-inherited-configuration)))
3238    (return (nreverse x))))
3239
3240(defun* validate-configuration-file (file validator &key description)
3241  (let ((forms (read-file-forms file)))
3242    (unless (length=n-p forms 1)
3243      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
3244             description forms))
3245    (funcall validator (car forms) :location file)))
3246
3247(defun* hidden-file-p (pathname)
3248  (equal (first-char (pathname-name pathname)) #\.))
3249
3250(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
3251  (apply 'directory pathname-spec
3252         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
3253                             #+clozure '(:follow-links nil)
3254                             #+clisp '(:circle t :if-does-not-exist :ignore)
3255                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
3256                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
3257                                      '(:resolve-symlinks nil))))))
3258
3259(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
3260  "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
3261be applied to the results to yield a configuration form.  Current
3262values of TAG include :source-registry and :output-translations."
3263  (let ((files (sort (ignore-errors
3264                       (remove-if
3265                        'hidden-file-p
3266                        (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
3267                     #'string< :key #'namestring)))
3268    `(,tag
3269      ,@(loop :for file :in files :append
3270          (loop :with ignore-invalid-p = nil
3271            :for form :in (read-file-forms file)
3272            :when (eq form :ignore-invalid-entries)
3273              :do (setf ignore-invalid-p t)
3274            :else
3275              :when (funcall validator form)
3276                :collect form
3277              :else
3278                :when ignore-invalid-p
3279                  :do (setf *ignored-configuration-form* t)
3280                :else
3281                  :do (report-invalid-form invalid-form-reporter :form form :location file)))
3282      :inherit-configuration)))
3283
3284
3285;;; ---------------------------------------------------------------------------
3286;;; asdf-output-translations
3287;;;
3288;;; this code is heavily inspired from
3289;;; asdf-binary-translations, common-lisp-controller and cl-launch.
3290;;; ---------------------------------------------------------------------------
3291
3292(defvar *output-translations* ()
3293  "Either NIL (for uninitialized), or a list of one element,
3294said element itself being a sorted list of mappings.
3295Each mapping is a pair of a source pathname and destination pathname,
3296and the order is by decreasing length of namestring of the source pathname.")
3297
3298(defvar *user-cache*
3299  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
3300    (or
3301     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
3302     (when (os-windows-p)
3303       (try (or #+lispworks (sys:get-folder-path :local-appdata)
3304                (getenv "LOCALAPPDATA")
3305                #+lispworks (sys:get-folder-path :appdata)
3306                (getenv "APPDATA"))
3307            "common-lisp" "cache" :implementation))
3308     '(:home ".cache" "common-lisp" :implementation))))
3309
3310(defun* output-translations ()
3311  (car *output-translations*))
3312
3313(defun* (setf output-translations) (new-value)
3314  (setf *output-translations*
3315        (list
3316         (stable-sort (copy-list new-value) #'>
3317                      :key #'(lambda (x)
3318                               (etypecase (car x)
3319                                 ((eql t) -1)
3320                                 (pathname
3321                                  (let ((directory (pathname-directory (car x))))
3322                                    (if (listp directory) (length directory) 0))))))))
3323  new-value)
3324
3325(defun* output-translations-initialized-p ()
3326  (and *output-translations* t))
3327
3328(defun* clear-output-translations ()
3329  "Undoes any initialization of the output translations.
3330You might want to call that before you dump an image that would be resumed
3331with a different configuration, so the configuration would be re-read then."
3332  (setf *output-translations* '())
3333  (values))
3334
3335(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
3336                          (values (or null pathname) &optional))
3337                resolve-location))
3338
3339(defun* resolve-relative-location-component (x &key directory wilden)
3340  (let ((r (etypecase x
3341             (pathname x)
3342             (string (coerce-pathname x :type (when directory :directory)))
3343             (cons
3344              (if (null (cdr x))
3345                  (resolve-relative-location-component
3346                   (car x) :directory directory :wilden wilden)
3347                  (let* ((car (resolve-relative-location-component
3348                               (car x) :directory t :wilden nil)))
3349                    (merge-pathnames*
3350                     (resolve-relative-location-component
3351                      (cdr x) :directory directory :wilden wilden)
3352                     car))))
3353             ((eql :default-directory)
3354              (relativize-pathname-directory (default-directory)))
3355             ((eql :*/) *wild-directory*)
3356             ((eql :**/) *wild-inferiors*)
3357             ((eql :*.*.*) *wild-file*)
3358             ((eql :implementation)
3359              (coerce-pathname (implementation-identifier) :type :directory))
3360             ((eql :implementation-type)
3361              (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
3362    (when (absolute-pathname-p r)
3363      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
3364    (if (or (pathnamep x) (not wilden)) r (wilden r))))
3365
3366(defvar *here-directory* nil
3367  "This special variable is bound to the currect directory during calls to
3368PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
3369directive.")
3370
3371(defun* resolve-absolute-location-component (x &key directory wilden)
3372  (let* ((r
3373          (etypecase x
3374            (pathname x)
3375            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
3376                      #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
3377                      (if directory (ensure-directory-pathname p) p)))
3378            (cons
3379             (return-from resolve-absolute-location-component
3380               (if (null (cdr x))
3381                   (resolve-absolute-location-component
3382                    (car x) :directory directory :wilden wilden)
3383                   (merge-pathnames*
3384                    (resolve-relative-location-component
3385                     (cdr x) :directory directory :wilden wilden)
3386                    (resolve-absolute-location-component
3387                     (car x) :directory t :wilden nil)))))
3388            ((eql :root)
3389             ;; special magic! we encode such paths as relative pathnames,
3390             ;; but it means "relative to the root of the source pathname's host and device".
3391             (return-from resolve-absolute-location-component
3392               (let ((p (make-pathname :directory '(:relative))))
3393                 (if wilden (wilden p) p))))
3394            ((eql :home) (user-homedir))
3395            ((eql :here)
3396             (resolve-location (or *here-directory*
3397                                   ;; give semantics in the case of use interactively
3398                                   :default-directory)
3399                          :directory t :wilden nil))
3400            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
3401            ((eql :system-cache)
3402             (error "Using the :system-cache is deprecated. ~%~
3403Please remove it from your ASDF configuration"))
3404            ((eql :default-directory) (default-directory))))
3405         (s (if (and wilden (not (pathnamep x)))
3406                (wilden r)
3407                r)))
3408    (unless (absolute-pathname-p s)
3409      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
3410    s))
3411
3412(defun* resolve-location (x &key directory wilden)
3413  (if (atom x)
3414      (resolve-absolute-location-component x :directory directory :wilden wilden)
3415      (loop :with path = (resolve-absolute-location-component
3416                          (car x) :directory (and (or directory (cdr x)) t)
3417                          :wilden (and wilden (null (cdr x))))
3418        :for (component . morep) :on (cdr x)
3419        :for dir = (and (or morep directory) t)
3420        :for wild = (and wilden (not morep))
3421        :do (setf path (merge-pathnames*
3422                        (resolve-relative-location-component
3423                         component :directory dir :wilden wild)
3424                        path))
3425        :finally (return path))))
3426
3427(defun* location-designator-p (x)
3428  (flet ((absolute-component-p (c)
3429           (typep c '(or string pathname
3430                      (member :root :home :here :user-cache :system-cache :default-directory))))
3431         (relative-component-p (c)
3432           (typep c '(or string pathname
3433                      (member :default-directory :*/ :**/ :*.*.*
3434                        :implementation :implementation-type)))))
3435    (or (typep x 'boolean)
3436        (absolute-component-p x)
3437        (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
3438
3439(defun* location-function-p (x)
3440  (and
3441   (consp x)
3442   (length=n-p x 2)
3443   (or (and (equal (first x) :function)
3444            (typep (second x) 'symbol))
3445       (and (equal (first x) 'lambda)
3446            (cddr x)
3447            (length=n-p (second x) 2)))))
3448
3449(defun* validate-output-translations-directive (directive)
3450  (or (member directive '(:enable-user-cache :disable-cache nil))
3451      (and (consp directive)
3452           (or (and (length=n-p directive 2)
3453                    (or (and (eq (first directive) :include)
3454                             (typep (second directive) '(or string pathname null)))
3455                        (and (location-designator-p (first directive))
3456                             (or (location-designator-p (second directive))
3457                                 (location-function-p (second directive))))))
3458               (and (length=n-p directive 1)
3459                    (location-designator-p (first directive)))))))
3460
3461(defun* validate-output-translations-form (form &key location)
3462  (validate-configuration-form
3463   form
3464   :output-translations
3465   'validate-output-translations-directive
3466   :location location :invalid-form-reporter 'invalid-output-translation))
3467
3468(defun* validate-output-translations-file (file)
3469  (validate-configuration-file
3470   file 'validate-output-translations-form :description "output translations"))
3471
3472(defun* validate-output-translations-directory (directory)
3473  (validate-configuration-directory
3474   directory :output-translations 'validate-output-translations-directive
3475   :invalid-form-reporter 'invalid-output-translation))
3476
3477(defun* parse-output-translations-string (string &key location)
3478  (cond
3479    ((or (null string) (equal string ""))
3480     '(:output-translations :inherit-configuration))
3481    ((not (stringp string))
3482     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
3483    ((eql (char string 0) #\")
3484     (parse-output-translations-string (read-from-string string) :location location))
3485    ((eql (char string 0) #\()
3486     (validate-output-translations-form (read-from-string string) :location location))
3487    (t
3488     (loop
3489      :with inherit = nil
3490      :with directives = ()
3491      :with start = 0
3492      :with end = (length string)
3493      :with source = nil
3494      :with separator = (inter-directory-separator)
3495      :for i = (or (position separator string :start start) end) :do
3496      (let ((s (subseq string start i)))
3497        (cond
3498          (source
3499           (push (list source (if (equal "" s) nil s)) directives)
3500           (setf source nil))
3501          ((equal "" s)
3502           (when inherit
3503             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
3504                    string))
3505           (setf inherit t)
3506           (push :inherit-configuration directives))
3507          (t
3508           (setf source s)))
3509        (setf start (1+ i))
3510        (when (> start end)
3511          (when source
3512            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
3513                   string))
3514          (unless inherit
3515            (push :ignore-inherited-configuration directives))
3516          (return `(:output-translations ,@(nreverse directives)))))))))
3517
3518(defparameter *default-output-translations*
3519  '(environment-output-translations
3520    user-output-translations-pathname
3521    user-output-translations-directory-pathname
3522    system-output-translations-pathname
3523    system-output-translations-directory-pathname))
3524
3525(defun* wrapping-output-translations ()
3526  `(:output-translations
3527    ;; Some implementations have precompiled ASDF systems,
3528    ;; so we must disable translations for implementation paths.
3529    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
3530                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
3531    ;; The below two are not needed: no precompiled ASDF system there
3532    ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
3533    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
3534    ;; All-import, here is where we want user stuff to be:
3535    :inherit-configuration
3536    ;; These are for convenience, and can be overridden by the user:
3537    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
3538    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
3539    ;; We enable the user cache by default, and here is the place we do:
3540    :enable-user-cache))
3541
3542(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
3543(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
3544
3545(defun* user-output-translations-pathname (&key (direction :input))
3546  (in-user-configuration-directory *output-translations-file* :direction direction))
3547(defun* system-output-translations-pathname (&key (direction :input))
3548  (in-system-configuration-directory *output-translations-file* :direction direction))
3549(defun* user-output-translations-directory-pathname (&key (direction :input))
3550  (in-user-configuration-directory *output-translations-directory* :direction direction))
3551(defun* system-output-translations-directory-pathname (&key (direction :input))
3552  (in-system-configuration-directory *output-translations-directory* :direction direction))
3553(defun* environment-output-translations ()
3554  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
3555
3556(defgeneric* process-output-translations (spec &key inherit collect))
3557(declaim (ftype (function (t &key (:collect (or symbol function))) t)
3558                inherit-output-translations))
3559(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
3560                process-output-translations-directive))
3561
3562(defmethod process-output-translations ((x symbol) &key
3563                                        (inherit *default-output-translations*)
3564                                        collect)
3565  (process-output-translations (funcall x) :inherit inherit :collect collect))
3566(defmethod process-output-translations ((pathname pathname) &key inherit collect)
3567  (cond
3568    ((directory-pathname-p pathname)
3569     (process-output-translations (validate-output-translations-directory pathname)
3570                                  :inherit inherit :collect collect))
3571    ((probe-file* pathname)
3572     (process-output-translations (validate-output-translations-file pathname)
3573                                  :inherit inherit :collect collect))
3574    (t
3575     (inherit-output-translations inherit :collect collect))))
3576(defmethod process-output-translations ((string string) &key inherit collect)
3577  (process-output-translations (parse-output-translations-string string)
3578                               :inherit inherit :collect collect))
3579(defmethod process-output-translations ((x null) &key inherit collect)
3580  (declare (ignorable x))
3581  (inherit-output-translations inherit :collect collect))
3582(defmethod process-output-translations ((form cons) &key inherit collect)
3583  (dolist (directive (cdr (validate-output-translations-form form)))
3584    (process-output-translations-directive directive :inherit inherit :collect collect)))
3585
3586(defun* inherit-output-translations (inherit &key collect)
3587  (when inherit
3588    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
3589
3590(defun* process-output-translations-directive (directive &key inherit collect)
3591  (if (atom directive)
3592      (ecase directive
3593        ((:enable-user-cache)
3594         (process-output-translations-directive '(t :user-cache) :collect collect))
3595        ((:disable-cache)
3596         (process-output-translations-directive '(t t) :collect collect))
3597        ((:inherit-configuration)
3598         (inherit-output-translations inherit :collect collect))
3599        ((:ignore-inherited-configuration :ignore-invalid-entries nil)
3600         nil))
3601      (let ((src (first directive))
3602            (dst (second directive)))
3603        (if (eq src :include)
3604            (when dst
3605              (process-output-translations (pathname dst) :inherit nil :collect collect))
3606            (when src
3607              (let ((trusrc (or (eql src t)
3608                                (let ((loc (resolve-location src :directory t :wilden t)))
3609                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
3610                (cond
3611                  ((location-function-p dst)
3612                   (funcall collect
3613                            (list trusrc
3614                                  (if (symbolp (second dst))
3615                                      (fdefinition (second dst))
3616                                      (eval (second dst))))))
3617                  ((eq dst t)
3618                   (funcall collect (list trusrc t)))
3619                  (t
3620                   (let* ((trudst (if dst
3621                                      (resolve-location dst :directory t :wilden t)
3622                                      trusrc))
3623                          (wilddst (merge-pathnames* *wild-file* trudst)))
3624                     (funcall collect (list wilddst t))
3625                     (funcall collect (list trusrc trudst)))))))))))
3626
3627(defun* compute-output-translations (&optional parameter)
3628  "read the configuration, return it"
3629  (remove-duplicates
3630   (while-collecting (c)
3631     (inherit-output-translations
3632      `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
3633   :test 'equal :from-end t))
3634
3635(defvar *output-translations-parameter* nil)
3636
3637(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
3638  "read the configuration, initialize the internal configuration variable,
3639return the configuration"
3640  (setf *output-translations-parameter* parameter
3641        (output-translations) (compute-output-translations parameter)))
3642
3643(defun* disable-output-translations ()
3644  "Initialize output translations in a way that maps every file to itself,
3645effectively disabling the output translation facility."
3646  (initialize-output-translations
3647   '(:output-translations :disable-cache :ignore-inherited-configuration)))
3648
3649;; checks an initial variable to see whether the state is initialized
3650;; or cleared. In the former case, return current configuration; in
3651;; the latter, initialize.  ASDF will call this function at the start
3652;; of (asdf:find-system).
3653(defun* ensure-output-translations ()
3654  (if (output-translations-initialized-p)
3655      (output-translations)
3656      (initialize-output-translations)))
3657
3658(defun* translate-pathname* (path absolute-source destination &optional root source)
3659  (declare (ignore source))
3660  (cond
3661    ((functionp destination)
3662     (funcall destination path absolute-source))
3663    ((eq destination t)
3664     path)
3665    ((not (pathnamep destination))
3666     (error "Invalid destination"))
3667    ((not (absolute-pathname-p destination))
3668     (translate-pathname path absolute-source (merge-pathnames* destination root)))
3669    (root
3670     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
3671    (t
3672     (translate-pathname path absolute-source destination))))
3673
3674(defun* apply-output-translations (path)
3675  #+cormanlisp (truenamize path) #-cormanlisp
3676  (etypecase path
3677    (logical-pathname
3678     path)
3679    ((or pathname string)
3680     (ensure-output-translations)
3681     (loop :with p = (truenamize path)
3682       :for (source destination) :in (car *output-translations*)
3683       :for root = (when (or (eq source t)
3684                             (and (pathnamep source)
3685                                  (not (absolute-pathname-p source))))
3686                     (pathname-root p))
3687       :for absolute-source = (cond
3688                                ((eq source t) (wilden root))
3689                                (root (merge-pathnames* source root))
3690                                (t source))
3691       :when (or (eq source t) (pathname-match-p p absolute-source))
3692       :return (translate-pathname* p absolute-source destination root source)
3693       :finally (return p)))))
3694
3695(defmethod output-files :around (operation component)
3696  "Translate output files, unless asked not to"
3697  operation component ;; hush genera, not convinced by declare ignorable(!)
3698  (values
3699   (multiple-value-bind (files fixedp) (call-next-method)
3700     (if fixedp
3701         files
3702         (mapcar #'apply-output-translations files)))
3703   t))
3704
3705(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
3706  (if (absolute-pathname-p output-file)
3707      ;; what cfp should be doing, w/ mp* instead of mp
3708      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
3709             (defaults (make-pathname
3710                        :type type :defaults (merge-pathnames* input-file))))
3711        (merge-pathnames* output-file defaults))
3712      (apply-output-translations
3713       (apply 'compile-file-pathname input-file keys))))
3714
3715(defun* tmpize-pathname (x)
3716  (make-pathname
3717   :name (strcat "ASDF-TMP-" (pathname-name x))
3718   :defaults x))
3719
3720(defun* delete-file-if-exists (x)
3721  (when (and x (probe-file* x))
3722    (delete-file x)))
3723
3724(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
3725  (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
3726         (tmp-file (tmpize-pathname output-file))
3727         (status :error))
3728    (multiple-value-bind (output-truename warnings-p failure-p)
3729        (apply 'compile-file input-file :output-file tmp-file keys)
3730      (cond
3731        (failure-p
3732         (setf status *compile-file-failure-behaviour*))
3733        (warnings-p
3734         (setf status *compile-file-warnings-behaviour*))
3735        (t
3736         (setf status :success)))
3737      (ecase status
3738        ((:success :warn :ignore)
3739         (delete-file-if-exists output-file)
3740         (when output-truename
3741           (rename-file output-truename output-file)
3742           (setf output-truename output-file)))
3743        (:error
3744         (delete-file-if-exists output-truename)
3745         (setf output-truename nil)))
3746      (values output-truename warnings-p failure-p))))
3747
3748#+abcl
3749(defun* translate-jar-pathname (source wildcard)
3750  (declare (ignore wildcard))
3751  (let* ((p (pathname (first (pathname-device source))))
3752         (root (format nil "/___jar___file___root___/~@[~A/~]"
3753                       (and (find :windows *features*)
3754                            (pathname-device p)))))
3755    (apply-output-translations
3756     (merge-pathnames*
3757      (relativize-pathname-directory source)
3758      (merge-pathnames*
3759       (relativize-pathname-directory (ensure-directory-pathname p))
3760       root)))))
3761
3762;;;; -----------------------------------------------------------------
3763;;;; Compatibility mode for ASDF-Binary-Locations
3764
3765(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
3766  (declare (ignorable operation-class system args))
3767  (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
3768    (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
3769ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
3770which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
3771and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
3772In case you insist on preserving your previous A-B-L configuration, but
3773do not know how to achieve the same effect with A-O-T, you may use function
3774ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
3775call that function where you would otherwise have loaded and configured A-B-L.")))
3776
3777(defun* enable-asdf-binary-locations-compatibility
3778    (&key
3779     (centralize-lisp-binaries nil)
3780     (default-toplevel-directory
3781         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
3782     (include-per-user-information nil)
3783     (map-all-source-files (or #+(or ecl clisp) t nil))
3784     (source-to-target-mappings nil))
3785  #+(or ecl clisp)
3786  (when (null map-all-source-files)
3787    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
3788  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
3789         (mapped-files (if map-all-source-files *wild-file*
3790                           (make-pathname :type fasl-type :defaults *wild-file*)))
3791         (destination-directory
3792          (if centralize-lisp-binaries
3793              `(,default-toplevel-directory
3794                ,@(when include-per-user-information
3795                        (cdr (pathname-directory (user-homedir))))
3796                :implementation ,*wild-inferiors*)
3797              `(:root ,*wild-inferiors* :implementation))))
3798    (initialize-output-translations
3799     `(:output-translations
3800       ,@source-to-target-mappings
3801       ((:root ,*wild-inferiors* ,mapped-files)
3802        (,@destination-directory ,mapped-files))
3803       (t t)
3804       :ignore-inherited-configuration))))
3805
3806;;;; -----------------------------------------------------------------
3807;;;; Source Registry Configuration, by Francois-Rene Rideau
3808;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
3809
3810;; Using ack 1.2 exclusions
3811(defvar *default-source-registry-exclusions*
3812  '(".bzr" ".cdv"
3813    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
3814    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
3815    "_sgbak" "autom4te.cache" "cover_db" "_build"
3816    "debian")) ;; debian often builds stuff under the debian directory... BAD.
3817
3818(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
3819
3820(defvar *source-registry* nil
3821  "Either NIL (for uninitialized), or an equal hash-table, mapping
3822system names to pathnames of .asd files")
3823
3824(defun* source-registry-initialized-p ()
3825  (typep *source-registry* 'hash-table))
3826
3827(defun* clear-source-registry ()
3828  "Undoes any initialization of the source registry.
3829You might want to call that before you dump an image that would be resumed
3830with a different configuration, so the configuration would be re-read then."
3831  (setf *source-registry* nil)
3832  (values))
3833
3834(defparameter *wild-asd*
3835  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
3836
3837(defun* filter-logical-directory-results (directory entries merger)
3838  (if (typep directory 'logical-pathname)
3839      ;; Try hard to not resolve logical-pathname into physical pathnames;
3840      ;; otherwise logical-pathname users/lovers will be disappointed.
3841      ;; If directory* could use some implementation-dependent magic,
3842      ;; we will have logical pathnames already; otherwise,
3843      ;; we only keep pathnames for which specifying the name and
3844      ;; translating the LPN commute.
3845      (loop :for f :in entries
3846        :for p = (or (and (typep f 'logical-pathname) f)
3847                     (let* ((u (ignore-errors (funcall merger f))))
3848                       ;; The first u avoids a cumbersome (truename u) error
3849                       (and u (equal (ignore-errors (truename u)) f) u)))
3850        :when p :collect p)
3851      entries))
3852
3853(defun* directory-files (directory &optional (pattern *wild-file*))
3854  (when (wild-pathname-p directory)
3855    (error "Invalid wild in ~S" directory))
3856  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
3857    (error "Invalid file pattern ~S" pattern))
3858  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
3859    (filter-logical-directory-results
3860     directory entries
3861     #'(lambda (f)
3862         (make-pathname :defaults directory
3863                        :name (pathname-name f) :type (ununspecific (pathname-type f))
3864                        :version (ununspecific (pathname-version f)))))))
3865
3866(defun* directory-asd-files (directory)
3867  (directory-files directory *wild-asd*))
3868
3869(defun* subdirectories (directory)
3870  (let* ((directory (ensure-directory-pathname directory))
3871         #-(or abcl cormanlisp genera xcl)
3872         (wild (merge-pathnames*
3873                #-(or abcl allegro cmu lispworks sbcl scl xcl)
3874                *wild-directory*
3875                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
3876                directory))
3877         (dirs
3878          #-(or abcl cormanlisp genera xcl)
3879          (ignore-errors
3880            (directory* wild . #.(or #+clozure '(:directories t :files nil)
3881                                     #+mcl '(:directories t))))
3882          #+(or abcl xcl) (system:list-directory directory)
3883          #+cormanlisp (cl::directory-subdirs directory)
3884          #+genera (fs:directory-list directory))
3885         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
3886         (dirs (loop :for x :in dirs
3887                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
3888                          #+allegro (excl:probe-directory x)
3889                          #+(or cmu sbcl scl) (directory-pathname-p x)
3890                          #+genera (getf (cdr x) :directory)
3891                          #+lispworks (lw:file-directory-p x)
3892                 :when d :collect #+(or abcl allegro xcl) d
3893                                  #+genera (ensure-directory-pathname (first x))
3894                                  #+(or cmu lispworks sbcl scl) x)))
3895    (filter-logical-directory-results
3896     directory dirs
3897     (let ((prefix (normalize-pathname-directory-component
3898                    (pathname-directory directory))))
3899       #'(lambda (d)
3900           (let ((dir (normalize-pathname-directory-component
3901                       (pathname-directory d))))
3902             (and (consp dir) (consp (cdr dir))
3903                  (make-pathname
3904                   :defaults directory :name nil :type nil :version nil
3905                   :directory (append prefix (last dir))))))))))
3906
3907(defun* collect-asds-in-directory (directory collect)
3908  (map () collect (directory-asd-files directory)))
3909
3910(defun* collect-sub*directories (directory collectp recursep collector)
3911  (when (funcall collectp directory)
3912    (funcall collector directory))
3913  (dolist (subdir (subdirectories directory))
3914    (when (funcall recursep subdir)
3915      (collect-sub*directories subdir collectp recursep collector))))
3916
3917(defun* collect-sub*directories-asd-files
3918    (directory &key
3919     (exclude *default-source-registry-exclusions*)
3920     collect)
3921  (collect-sub*directories
3922   directory
3923   (constantly t)
3924   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
3925   #'(lambda (dir) (collect-asds-in-directory dir collect))))
3926
3927(defun* validate-source-registry-directive (directive)
3928  (or (member directive '(:default-registry))
3929      (and (consp directive)
3930           (let ((rest (rest directive)))
3931             (case (first directive)
3932               ((:include :directory :tree)
3933                (and (length=n-p rest 1)
3934                     (location-designator-p (first rest))))
3935               ((:exclude :also-exclude)
3936                (every #'stringp rest))
3937               ((:default-registry)
3938                (null rest)))))))
3939
3940(defun* validate-source-registry-form (form &key location)
3941  (validate-configuration-form
3942   form :source-registry 'validate-source-registry-directive
3943   :location location :invalid-form-reporter 'invalid-source-registry))
3944
3945(defun* validate-source-registry-file (file)
3946  (validate-configuration-file
3947   file 'validate-source-registry-form :description "a source registry"))
3948
3949(defun* validate-source-registry-directory (directory)
3950  (validate-configuration-directory
3951   directory :source-registry 'validate-source-registry-directive
3952   :invalid-form-reporter 'invalid-source-registry))
3953
3954(defun* parse-source-registry-string (string &key location)
3955  (cond
3956    ((or (null string) (equal string ""))
3957     '(:source-registry :inherit-configuration))
3958    ((not (stringp string))
3959     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
3960    ((find (char string 0) "\"(")
3961     (validate-source-registry-form (read-from-string string) :location location))
3962    (t
3963     (loop
3964      :with inherit = nil
3965      :with directives = ()
3966      :with start = 0
3967      :with end = (length string)
3968      :with separator = (inter-directory-separator)
3969      :for pos = (position separator string :start start) :do
3970      (let ((s (subseq string start (or pos end))))
3971        (flet ((check (dir)
3972                 (unless (absolute-pathname-p dir)
3973                   (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
3974                 dir))
3975          (cond
3976            ((equal "" s) ; empty element: inherit
3977             (when inherit
3978               (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
3979                      string))
3980             (setf inherit t)
3981             (push ':inherit-configuration directives))
3982            ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
3983             (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
3984            (t
3985             (push `(:directory ,(check s)) directives))))
3986        (cond
3987          (pos
3988           (setf start (1+ pos)))
3989          (t
3990           (unless inherit
3991             (push '(:ignore-inherited-configuration) directives))
3992           (return `(:source-registry ,@(nreverse directives))))))))))
3993
3994(defun* register-asd-directory (directory &key recurse exclude collect)
3995  (if (not recurse)
3996      (collect-asds-in-directory directory collect)
3997      (collect-sub*directories-asd-files
3998       directory :exclude exclude :collect collect)))
3999
4000(defparameter *default-source-registries*
4001  '(environment-source-registry
4002    user-source-registry
4003    user-source-registry-directory
4004    system-source-registry
4005    system-source-registry-directory
4006    default-source-registry))
4007
4008(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
4009(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
4010
4011(defun* wrapping-source-registry ()
4012  `(:source-registry
4013    #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
4014    :inherit-configuration
4015    #+cmu (:tree #p"modules:")
4016    #+scl (:tree #p"file://modules/")))
4017(defun* default-source-registry ()
4018  `(:source-registry
4019    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
4020    (:directory ,(default-directory))
4021      ,@(loop :for dir :in
4022          `(,@(when (os-unix-p)
4023                `(,(or (getenv "XDG_DATA_HOME")
4024                       (subpathname (user-homedir) ".local/share/"))
4025                  ,@(split-string (or (getenv "XDG_DATA_DIRS")
4026                                      "/usr/local/share:/usr/share")
4027                                  :separator ":")))
4028            ,@(when (os-windows-p)
4029                `(,(or #+lispworks (sys:get-folder-path :local-appdata)
4030                       (getenv "LOCALAPPDATA"))
4031                  ,(or #+lispworks (sys:get-folder-path :appdata)
4032                       (getenv "APPDATA"))
4033                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
4034                       (getenv "ALLUSERSAPPDATA")
4035                       (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")))))
4036          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
4037          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
4038      :inherit-configuration))
4039(defun* user-source-registry (&key (direction :input))
4040  (in-user-configuration-directory *source-registry-file* :direction direction))
4041(defun* system-source-registry (&key (direction :input))
4042  (in-system-configuration-directory *source-registry-file* :direction direction))
4043(defun* user-source-registry-directory (&key (direction :input))
4044  (in-user-configuration-directory *source-registry-directory* :direction direction))
4045(defun* system-source-registry-directory (&key (direction :input))
4046  (in-system-configuration-directory *source-registry-directory* :direction direction))
4047(defun* environment-source-registry ()
4048  (getenv "CL_SOURCE_REGISTRY"))
4049
4050(defgeneric* process-source-registry (spec &key inherit register))
4051(declaim (ftype (function (t &key (:register (or symbol function))) t)
4052                inherit-source-registry))
4053(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
4054                process-source-registry-directive))
4055
4056(defmethod process-source-registry ((x symbol) &key inherit register)
4057  (process-source-registry (funcall x) :inherit inherit :register register))
4058(defmethod process-source-registry ((pathname pathname) &key inherit register)
4059  (cond
4060    ((directory-pathname-p pathname)
4061     (let ((*here-directory* (truenamize pathname)))
4062       (process-source-registry (validate-source-registry-directory pathname)
4063                                :inherit inherit :register register)))
4064    ((probe-file* pathname)
4065     (let ((*here-directory* (pathname-directory-pathname pathname)))
4066       (process-source-registry (validate-source-registry-file pathname)
4067                                :inherit inherit :register register)))
4068    (t
4069     (inherit-source-registry inherit :register register))))
4070(defmethod process-source-registry ((string string) &key inherit register)
4071  (process-source-registry (parse-source-registry-string string)
4072                           :inherit inherit :register register))
4073(defmethod process-source-registry ((x null) &key inherit register)
4074  (declare (ignorable x))
4075  (inherit-source-registry inherit :register register))
4076(defmethod process-source-registry ((form cons) &key inherit register)
4077  (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
4078    (dolist (directive (cdr (validate-source-registry-form form)))
4079      (process-source-registry-directive directive :inherit inherit :register register))))
4080
4081(defun* inherit-source-registry (inherit &key register)
4082  (when inherit
4083    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
4084
4085(defun* process-source-registry-directive (directive &key inherit register)
4086  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
4087    (ecase kw
4088      ((:include)
4089       (destructuring-bind (pathname) rest
4090         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
4091      ((:directory)
4092       (destructuring-bind (pathname) rest
4093         (when pathname
4094           (funcall register (resolve-location pathname :directory t)))))
4095      ((:tree)
4096       (destructuring-bind (pathname) rest
4097         (when pathname
4098           (funcall register (resolve-location pathname :directory t)
4099                    :recurse t :exclude *source-registry-exclusions*))))
4100      ((:exclude)
4101       (setf *source-registry-exclusions* rest))
4102      ((:also-exclude)
4103       (appendf *source-registry-exclusions* rest))
4104      ((:default-registry)
4105       (inherit-source-registry '(default-source-registry) :register register))
4106      ((:inherit-configuration)
4107       (inherit-source-registry inherit :register register))
4108      ((:ignore-inherited-configuration)
4109       nil)))
4110  nil)
4111
4112(defun* flatten-source-registry (&optional parameter)
4113  (remove-duplicates
4114   (while-collecting (collect)
4115     (let ((*default-pathname-defaults* (default-directory)))
4116       (inherit-source-registry
4117        `(wrapping-source-registry
4118          ,parameter
4119          ,@*default-source-registries*)
4120        :register #'(lambda (directory &key recurse exclude)
4121                      (collect (list directory :recurse recurse :exclude exclude)))))
4122     :test 'equal :from-end t)))
4123
4124;; Will read the configuration and initialize all internal variables.
4125(defun* compute-source-registry (&optional parameter (registry *source-registry*))
4126  (dolist (entry (flatten-source-registry parameter))
4127    (destructuring-bind (directory &key recurse exclude) entry
4128      (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
4129        (register-asd-directory
4130         directory :recurse recurse :exclude exclude :collect
4131         #'(lambda (asd)
4132             (let* ((name (pathname-name asd))
4133                    (name (if (typep asd 'logical-pathname)
4134                              ;; logical pathnames are upper-case,
4135                              ;; at least in the CLHS and on SBCL,
4136                              ;; yet (coerce-name :foo) is lower-case.
4137                              ;; won't work well with (load-system "Foo")
4138                              ;; instead of (load-system 'foo)
4139                              (string-downcase name)
4140                              name)))
4141               (cond
4142                 ((gethash name registry) ; already shadowed by something else
4143                  nil)
4144                 ((gethash name h) ; conflict at current level
4145                  (when *asdf-verbose*
4146                    (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
4147                                found several entries for ~A - picking ~S over ~S~:>")
4148                          directory recurse name (gethash name h) asd)))
4149                 (t
4150                  (setf (gethash name registry) asd)
4151                  (setf (gethash name h) asd))))))
4152        h)))
4153  (values))
4154
4155(defvar *source-registry-parameter* nil)
4156
4157(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
4158  (setf *source-registry-parameter* parameter)
4159  (setf *source-registry* (make-hash-table :test 'equal))
4160  (compute-source-registry parameter))
4161
4162;; Checks an initial variable to see whether the state is initialized
4163;; or cleared. In the former case, return current configuration; in
4164;; the latter, initialize.  ASDF will call this function at the start
4165;; of (asdf:find-system) to make sure the source registry is initialized.
4166;; However, it will do so *without* a parameter, at which point it
4167;; will be too late to provide a parameter to this function, though
4168;; you may override the configuration explicitly by calling
4169;; initialize-source-registry directly with your parameter.
4170(defun* ensure-source-registry (&optional parameter)
4171  (unless (source-registry-initialized-p)
4172    (initialize-source-registry parameter))
4173  (values))
4174
4175(defun* sysdef-source-registry-search (system)
4176  (ensure-source-registry)
4177  (values (gethash (coerce-name system) *source-registry*)))
4178
4179(defun* clear-configuration ()
4180  (clear-source-registry)
4181  (clear-output-translations))
4182
4183
4184;;; ECL support for COMPILE-OP / LOAD-OP
4185;;;
4186;;; In ECL, these operations produce both FASL files and the
4187;;; object files that they are built from. Having both of them allows
4188;;; us to later on reuse the object files for bundles, libraries,
4189;;; standalone executables, etc.
4190;;;
4191;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
4192;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
4193;;;
4194#+ecl
4195(progn
4196  (setf *compile-op-compile-file-function* 'ecl-compile-file)
4197
4198  (defun use-ecl-byte-compiler-p ()
4199    (member :ecl-bytecmp *features*))
4200
4201  (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
4202    (if (use-ecl-byte-compiler-p)
4203        (apply 'compile-file* input-file keys)
4204        (multiple-value-bind (object-file flags1 flags2)
4205            (apply 'compile-file* input-file :system-p t keys)
4206          (values (and object-file
4207                       (c::build-fasl (compile-file-pathname object-file :type :fasl)
4208                                      :lisp-files (list object-file))
4209                       object-file)
4210                  flags1
4211                  flags2))))
4212
4213  (defmethod output-files ((operation compile-op) (c cl-source-file))
4214    (declare (ignorable operation))
4215    (let* ((p (lispize-pathname (component-pathname c)))
4216           (f (compile-file-pathname p :type :fasl)))
4217      (if (use-ecl-byte-compiler-p)
4218          (list f)
4219          (list (compile-file-pathname p :type :object) f))))
4220
4221  (defmethod perform ((o load-op) (c cl-source-file))
4222    (map () #'load
4223         (loop :for i :in (input-files o c)
4224           :unless (string= (pathname-type i) "fas")
4225               :collect (compile-file-pathname (lispize-pathname i))))))
4226
4227;;;; -----------------------------------------------------------------
4228;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
4229;;;;
4230(defvar *require-asdf-operator* 'load-op)
4231
4232(defun* module-provide-asdf (name)
4233  (handler-bind
4234      ((style-warning #'muffle-warning)
4235       #-genera
4236       (missing-component (constantly nil))
4237       (error #'(lambda (e)
4238                  (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
4239                          name e))))
4240    (let ((*verbose-out* (make-broadcast-stream))
4241          (system (find-system (string-downcase name) nil)))
4242      (when system
4243        (operate *require-asdf-operator* system :verbose nil)
4244        t))))
4245
4246#+(or abcl clisp clozure cmu ecl sbcl)
4247(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
4248  (when x
4249    (eval `(pushnew 'module-provide-asdf
4250            #+abcl sys::*module-provider-functions*
4251            #+clisp ,x
4252            #+clozure ccl:*module-provider-functions*
4253            #+(or cmu ecl) ext:*module-provider-functions*
4254            #+sbcl sb-ext:*module-provider-functions*))))
4255
4256
4257;;;; -------------------------------------------------------------------------
4258;;;; Cleanups after hot-upgrade.
4259;;;; Things to do in case we're upgrading from a previous version of ASDF.
4260;;;; See https://bugs.launchpad.net/asdf/+bug/485687
4261;;;;
4262
4263;;; If a previous version of ASDF failed to read some configuration, try again.
4264(when *ignored-configuration-form*
4265  (clear-configuration)
4266  (setf *ignored-configuration-form* nil))
4267
4268;;;; -----------------------------------------------------------------
4269;;;; Done!
4270(when *load-verbose*
4271  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
4272
4273#+allegro
4274(eval-when (:compile-toplevel :execute)
4275  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
4276    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
4277
4278(pushnew :asdf *features*)
4279(pushnew :asdf2 *features*)
4280
4281(provide :asdf)
4282
4283;;; Local Variables:
4284;;; mode: lisp
4285;;; End:
Note: See TracBrowser for help on using the repository browser.