source: trunk/source/tools/asdf.lisp @ 14380

Last change on this file since 14380 was 14380, checked in by rme, 9 years ago

Update to ASDF 2.010.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 147.8 KB
Line 
1;;; -*- mode: common-lisp; package: asdf; -*-
2;;; This is ASDF: 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 HEAD
14;;; is the latest development version, whereas the revision tagged
15;;; RELEASE 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-2010 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 :cl-user)
51
52(eval-when (:compile-toplevel :load-toplevel :execute)
53  ;;; make package if it doesn't exist yet.
54  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
55  (unless (find-package :asdf)
56    (make-package :asdf :use '(:cl)))
57  ;;; Implementation-dependent tweaks
58  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
59  #+allegro
60  (setf excl::*autoload-package-name-alist*
61        (remove "asdf" excl::*autoload-package-name-alist*
62                :test 'equalp :key 'car))
63  #+ecl (require :cmp))
64
65(in-package :asdf)
66
67;;;; Create packages in a way that is compatible with hot-upgrade.
68;;;; See https://bugs.launchpad.net/asdf/+bug/485687
69;;;; See more at the end of the file.
70
71(eval-when (:load-toplevel :compile-toplevel :execute)
72  (defvar *asdf-version* nil)
73  (defvar *upgraded-p* nil)
74  (let* ((asdf-version "2.010") ;; same as 2.146
75         (existing-asdf (fboundp 'find-system))
76         (existing-version *asdf-version*)
77         (already-there (equal asdf-version existing-version)))
78    (unless (and existing-asdf already-there)
79      (when existing-asdf
80        (format *error-output*
81                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
82                existing-version asdf-version))
83      (labels
84          ((unlink-package (package)
85             (let ((u (find-package package)))
86               (when u
87                 (ensure-unintern u
88                   (loop :for s :being :each :present-symbol :in u :collect s))
89                 (loop :for p :in (package-used-by-list u) :do
90                   (unuse-package u p))
91                 (delete-package u))))
92           (ensure-exists (name nicknames use)
93             (let ((previous
94                    (remove-duplicates
95                     (mapcar #'find-package (cons name nicknames))
96                     :from-end t)))
97               ;; do away with packages with conflicting (nick)names
98               (map () #'unlink-package (cdr previous))
99               ;; reuse previous package with same name
100               (let ((p (car previous)))
101                 (cond
102                   (p
103                    (rename-package p name nicknames)
104                    (ensure-use p use)
105                    p)
106                   (t
107                    (make-package name :nicknames nicknames :use use))))))
108           (find-sym (symbol package)
109             (find-symbol (string symbol) package))
110           (intern* (symbol package)
111             (intern (string symbol) package))
112           (remove-symbol (symbol package)
113             (let ((sym (find-sym symbol package)))
114               (when sym
115                 (unexport sym package)
116                 (unintern sym package)
117                 sym)))
118           (ensure-unintern (package symbols)
119             (loop :with packages = (list-all-packages)
120               :for sym :in symbols
121               :for removed = (remove-symbol sym package)
122               :when removed :do
123               (loop :for p :in packages :do
124                 (when (eq removed (find-sym sym p))
125                   (unintern removed p)))))
126           (ensure-shadow (package symbols)
127             (shadow symbols package))
128           (ensure-use (package use)
129             (dolist (used (reverse use))
130               (do-external-symbols (sym used)
131                 (unless (eq sym (find-sym sym package))
132                   (remove-symbol sym package)))
133               (use-package used package)))
134           (ensure-fmakunbound (package symbols)
135             (loop :for name :in symbols
136               :for sym = (find-sym name package)
137               :when sym :do (fmakunbound sym)))
138           (ensure-export (package export)
139             (let ((formerly-exported-symbols nil)
140                   (bothly-exported-symbols nil)
141                   (newly-exported-symbols nil))
142               (loop :for sym :being :each :external-symbol :in package :do
143                 (if (member sym export :test 'string-equal)
144                     (push sym bothly-exported-symbols)
145                     (push sym formerly-exported-symbols)))
146               (loop :for sym :in export :do
147                 (unless (member sym bothly-exported-symbols :test 'string-equal)
148                   (push sym newly-exported-symbols)))
149               (loop :for user :in (package-used-by-list package)
150                 :for shadowing = (package-shadowing-symbols user) :do
151                 (loop :for new :in newly-exported-symbols
152                   :for old = (find-sym new user)
153                   :when (and old (not (member old shadowing)))
154                   :do (unintern old user)))
155               (loop :for x :in newly-exported-symbols :do
156                 (export (intern* x package)))))
157           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
158             (let* ((p (ensure-exists name nicknames use)))
159               (ensure-unintern p unintern)
160               (ensure-shadow p shadow)
161               (ensure-export p export)
162               (ensure-fmakunbound p fmakunbound)
163               p)))
164        (macrolet
165            ((pkgdcl (name &key nicknames use export
166                           redefined-functions unintern fmakunbound shadow)
167                 `(ensure-package
168                   ',name :nicknames ',nicknames :use ',use :export ',export
169                   :shadow ',shadow
170                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
171                   :fmakunbound ',(append fmakunbound))))
172          (pkgdcl
173           :asdf
174           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
175           :use (:common-lisp)
176           :redefined-functions
177           (#:perform #:explain #:output-files #:operation-done-p
178            #:perform-with-restarts #:component-relative-pathname
179            #:system-source-file #:operate #:find-component #:find-system
180            #:apply-output-translations #:translate-pathname* #:resolve-location)
181           :unintern
182           (#:*asdf-revision* #:around #:asdf-method-combination
183            #:split #:make-collector)
184           :fmakunbound
185           (#:system-source-file
186            #:component-relative-pathname #:system-relative-pathname
187            #:process-source-registry
188            #:inherit-source-registry #:process-source-registry-directive)
189           :export
190           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
191            #:system-definition-pathname #:find-component ; miscellaneous
192            #:compile-system #:load-system #:test-system #:clear-system
193            #:compile-op #:load-op #:load-source-op
194            #:test-op
195            #:operation               ; operations
196            #:feature                 ; sort-of operation
197            #:version                 ; metaphorically sort-of an operation
198            #:version-satisfies
199
200            #:input-files #:output-files #:output-file #:perform ; operation methods
201            #:operation-done-p #:explain
202
203            #:component #:source-file
204            #:c-source-file #:cl-source-file #:java-source-file
205            #:static-file
206            #:doc-file
207            #:html-file
208            #:text-file
209            #:source-file-type
210            #:module                     ; components
211            #:system
212            #:unix-dso
213
214            #:module-components          ; component accessors
215            #:module-components-by-name  ; component accessors
216            #:component-pathname
217            #:component-relative-pathname
218            #:component-name
219            #:component-version
220            #:component-parent
221            #:component-property
222            #:component-system
223
224            #:component-depends-on
225
226            #:system-description
227            #:system-long-description
228            #:system-author
229            #:system-maintainer
230            #:system-license
231            #:system-licence
232            #:system-source-file
233            #:system-source-directory
234            #:system-relative-pathname
235            #:map-systems
236
237            #:operation-on-warnings
238            #:operation-on-failure
239            #:component-visited-p
240            ;;#:*component-parent-pathname*
241            #:*system-definition-search-functions*
242            #:*central-registry*         ; variables
243            #:*compile-file-warnings-behaviour*
244            #:*compile-file-failure-behaviour*
245            #:*resolve-symlinks*
246            #:*asdf-verbose*
247
248            #:asdf-version
249
250            #:operation-error #:compile-failed #:compile-warned #:compile-error
251            #:error-name
252            #:error-pathname
253            #:load-system-definition-error
254            #:error-component #:error-operation
255            #:system-definition-error
256            #:missing-component
257            #:missing-component-of-version
258            #:missing-dependency
259            #:missing-dependency-of-version
260            #:circular-dependency        ; errors
261            #:duplicate-names
262
263            #:try-recompiling
264            #:retry
265            #:accept                     ; restarts
266            #:coerce-entry-to-directory
267            #:remove-entry-from-registry
268
269            #:clear-configuration
270            #:initialize-output-translations
271            #:disable-output-translations
272            #:clear-output-translations
273            #:ensure-output-translations
274            #:apply-output-translations
275            #:compile-file*
276            #:compile-file-pathname*
277            #:enable-asdf-binary-locations-compatibility
278            #:*default-source-registries*
279            #:initialize-source-registry
280            #:compute-source-registry
281            #:clear-source-registry
282            #:ensure-source-registry
283            #:process-source-registry
284            #:system-registered-p
285            #:asdf-message
286
287            ;; Utilities
288            #:absolute-pathname-p
289            ;; #:aif #:it
290            ;; #:appendf
291            #:coerce-name
292            #:directory-pathname-p
293            ;; #:ends-with
294            #:ensure-directory-pathname
295            #:getenv
296            ;; #:get-uid
297            ;; #:length=n-p
298            #:merge-pathnames*
299            #:pathname-directory-pathname
300            #:read-file-forms
301            ;; #:remove-keys
302            ;; #:remove-keyword
303            #:resolve-symlinks
304            #:split-string
305            #:component-name-to-pathname-components
306            #:split-name-type
307            #:subdirectories
308            #:truenamize
309            #:while-collecting)))
310        (setf *asdf-version* asdf-version
311              *upgraded-p* (if existing-version
312                               (cons existing-version *upgraded-p*)
313                               *upgraded-p*))))))
314
315;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
316(when *upgraded-p*
317   #+ecl
318   (when (find-class 'compile-op nil)
319     (defmethod update-instance-for-redefined-class :after
320         ((c compile-op) added deleted plist &key)
321       (declare (ignore added deleted))
322       (let ((system-p (getf plist 'system-p)))
323         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
324   (when (find-class 'module nil)
325     (eval
326      '(progn
327         (defmethod update-instance-for-redefined-class :after
328             ((m module) added deleted plist &key)
329           (declare (ignorable deleted plist))
330           (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
331           (when (member 'components-by-name added)
332             (compute-module-components-by-name m)))
333         (defmethod update-instance-for-redefined-class :after
334             ((s system) added deleted plist &key)
335           (declare (ignorable deleted plist))
336           (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s))
337           (when (member 'source-file added)
338             (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s)))))))
339
340;;;; -------------------------------------------------------------------------
341;;;; User-visible parameters
342;;;;
343(defun asdf-version ()
344  "Exported interface to the version of ASDF currently installed. A string.
345You can compare this string with e.g.:
346(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
347  *asdf-version*)
348
349(defvar *resolve-symlinks* t
350  "Determine whether or not ASDF resolves symlinks when defining systems.
351
352Defaults to T.")
353
354(defvar *compile-file-warnings-behaviour*
355  (or #+clisp :ignore :warn)
356  "How should ASDF react if it encounters a warning when compiling a file?
357Valid values are :error, :warn, and :ignore.")
358
359(defvar *compile-file-failure-behaviour*
360  (or #+sbcl :error #+clisp :ignore :warn)
361  "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
362when compiling a file?  Valid values are :error, :warn, and :ignore.
363Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
364
365(defvar *verbose-out* nil)
366
367(defvar *asdf-verbose* t)
368
369(defparameter +asdf-methods+
370  '(perform-with-restarts perform explain output-files operation-done-p))
371
372#+allegro
373(eval-when (:compile-toplevel :execute)
374  (defparameter *acl-warn-save*
375                (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
376                  excl:*warn-on-nested-reader-conditionals*))
377  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
378    (setf excl:*warn-on-nested-reader-conditionals* nil)))
379
380;;;; -------------------------------------------------------------------------
381;;;; ASDF Interface, in terms of generic functions.
382(macrolet
383    ((defdef (def* def)
384       `(defmacro ,def* (name formals &rest rest)
385          `(progn
386             #+(or ecl gcl) (fmakunbound ',name)
387             ,(when (and #+ecl (symbolp name))
388                `(declaim (notinline ,name))) ; fails for setf functions on ecl
389             (,',def ,name ,formals ,@rest)))))
390  (defdef defgeneric* defgeneric)
391  (defdef defun* defun))
392
393(defgeneric* find-system (system &optional error-p))
394(defgeneric* perform-with-restarts (operation component))
395(defgeneric* perform (operation component))
396(defgeneric* operation-done-p (operation component))
397(defgeneric* explain (operation component))
398(defgeneric* output-files (operation component))
399(defgeneric* input-files (operation component))
400(defgeneric* component-operation-time (operation component))
401(defgeneric* operation-description (operation component)
402  (:documentation "returns a phrase that describes performing this operation
403on this component, e.g. \"loading /a/b/c\".
404You can put together sentences using this phrase."))
405
406(defgeneric* system-source-file (system)
407  (:documentation "Return the source file in which system is defined."))
408
409(defgeneric* component-system (component)
410  (:documentation "Find the top-level system containing COMPONENT"))
411
412(defgeneric* component-pathname (component)
413  (:documentation "Extracts the pathname applicable for a particular component."))
414
415(defgeneric* component-relative-pathname (component)
416  (:documentation "Returns a pathname for the component argument intended to be
417interpreted relative to the pathname of that component's parent.
418Despite the function's name, the return value may be an absolute
419pathname, because an absolute pathname may be interpreted relative to
420another pathname in a degenerate way."))
421
422(defgeneric* component-property (component property))
423
424(defgeneric* (setf component-property) (new-value component property))
425
426(defgeneric* version-satisfies (component version))
427
428(defgeneric* find-component (base path)
429  (:documentation "Finds the component with PATH starting from BASE module;
430if BASE is nil, then the component is assumed to be a system."))
431
432(defgeneric* source-file-type (component system))
433
434(defgeneric* operation-ancestor (operation)
435  (:documentation
436   "Recursively chase the operation's parent pointer until we get to
437the head of the tree"))
438
439(defgeneric* component-visited-p (operation component)
440  (:documentation "Returns the value stored by a call to
441VISIT-COMPONENT, if that has been called, otherwise NIL.
442This value stored will be a cons cell, the first element
443of which is a computed key, so not interesting.  The
444CDR wil be the DATA value stored by VISIT-COMPONENT; recover
445it as (cdr (component-visited-p op c)).
446  In the current form of ASDF, the DATA value retrieved is
447effectively a boolean, indicating whether some operations are
448to be performed in order to do OPERATION X COMPONENT.  If the
449data value is NIL, the combination had been explored, but no
450operations needed to be performed."))
451
452(defgeneric* visit-component (operation component data)
453  (:documentation "Record DATA as being associated with OPERATION
454and COMPONENT.  This is a side-effecting function:  the association
455will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
456OPERATION\).
457  No evidence that DATA is ever interesting, beyond just being
458non-NIL.  Using the data field is probably very risky; if there is
459already a record for OPERATION X COMPONENT, DATA will be quietly
460discarded instead of recorded.
461  Starting with 2.006, TRAVERSE will store an integer in data,
462so that nodes can be sorted in decreasing order of traversal."))
463
464
465(defgeneric* (setf visiting-component) (new-value operation component))
466
467(defgeneric* component-visiting-p (operation component))
468
469(defgeneric* component-depends-on (operation component)
470  (:documentation
471   "Returns a list of dependencies needed by the component to perform
472    the operation.  A dependency has one of the following forms:
473
474      (<operation> <component>*), where <operation> is a class
475        designator and each <component> is a component
476        designator, which means that the component depends on
477        <operation> having been performed on each <component>; or
478
479      (FEATURE <feature>), which means that the component depends
480        on <feature>'s presence in *FEATURES*.
481
482    Methods specialized on subclasses of existing component types
483    should usually append the results of CALL-NEXT-METHOD to the
484    list."))
485
486(defgeneric* component-self-dependencies (operation component))
487
488(defgeneric* traverse (operation component)
489  (:documentation
490"Generate and return a plan for performing OPERATION on COMPONENT.
491
492The plan returned is a list of dotted-pairs. Each pair is the CONS
493of ASDF operation object and a COMPONENT object. The pairs will be
494processed in order by OPERATE."))
495
496
497;;;; -------------------------------------------------------------------------
498;;;; General Purpose Utilities
499
500(defmacro while-collecting ((&rest collectors) &body body)
501  "COLLECTORS should be a list of names for collections.  A collector
502defines a function that, when applied to an argument inside BODY, will
503add its argument to the corresponding collection.  Returns multiple values,
504a list for each collection, in order.
505   E.g.,
506\(while-collecting \(foo bar\)
507           \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
508             \(foo \(first x\)\)
509             \(bar \(second x\)\)\)\)
510Returns two values: \(A B C\) and \(1 2 3\)."
511  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
512        (initial-values (mapcar (constantly nil) collectors)))
513    `(let ,(mapcar #'list vars initial-values)
514       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
515         ,@body
516         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
517
518(defmacro aif (test then &optional else)
519  `(let ((it ,test)) (if it ,then ,else)))
520
521(defun* pathname-directory-pathname (pathname)
522  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
523and NIL NAME, TYPE and VERSION components"
524  (when pathname
525    (make-pathname :name nil :type nil :version nil :defaults pathname)))
526
527(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
528  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
529does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
530Also, if either argument is NIL, then the other argument is returned unmodified."
531  (when (null specified) (return-from merge-pathnames* defaults))
532  (when (null defaults) (return-from merge-pathnames* specified))
533  (let* ((specified (pathname specified))
534         (defaults (pathname defaults))
535         (directory (pathname-directory specified))
536         (directory
537          (cond
538            #-(or sbcl cmu)
539            ((stringp directory) `(:absolute ,directory) directory)
540            #+gcl
541            ((and (consp directory) (stringp (first directory)))
542             `(:absolute ,@directory))
543            ((or (null directory)
544                 (and (consp directory) (member (first directory) '(:absolute :relative))))
545             directory)
546            (t
547             (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
548         (name (or (pathname-name specified) (pathname-name defaults)))
549         (type (or (pathname-type specified) (pathname-type defaults)))
550         (version (or (pathname-version specified) (pathname-version defaults))))
551    (labels ((ununspecific (x)
552               (if (eq x :unspecific) nil x))
553             (unspecific-handler (p)
554               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
555      (multiple-value-bind (host device directory unspecific-handler)
556          (ecase (first directory)
557            ((nil)
558             (values (pathname-host defaults)
559                     (pathname-device defaults)
560                     (pathname-directory defaults)
561                     (unspecific-handler defaults)))
562            ((:absolute)
563             (values (pathname-host specified)
564                     (pathname-device specified)
565                     directory
566                     (unspecific-handler specified)))
567            ((:relative)
568             (values (pathname-host defaults)
569                     (pathname-device defaults)
570                     (if (pathname-directory defaults)
571                         (append (pathname-directory defaults) (cdr directory))
572                         directory)
573                     (unspecific-handler defaults))))
574        (make-pathname :host host :device device :directory directory
575                       :name (funcall unspecific-handler name)
576                       :type (funcall unspecific-handler type)
577                       :version (funcall unspecific-handler version))))))
578
579(define-modify-macro appendf (&rest args)
580  append "Append onto list") ;; only to be used on short lists.
581
582(define-modify-macro orf (&rest args)
583  or "or a flag")
584
585(defun* first-char (s)
586  (and (stringp s) (plusp (length s)) (char s 0)))
587
588(defun* last-char (s)
589  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
590
591(defun* asdf-message (format-string &rest format-args)
592  (declare (dynamic-extent format-args))
593  (apply #'format *verbose-out* format-string format-args))
594
595(defun* split-string (string &key max (separator '(#\Space #\Tab)))
596  "Split STRING into a list of components separated by
597any of the characters in the sequence SEPARATOR.
598If MAX is specified, then no more than max(1,MAX) components will be returned,
599starting the separation from the end, e.g. when called with arguments
600 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
601  (block nil
602    (let ((list nil) (words 0) (end (length string)))
603      (flet ((separatorp (char) (find char separator))
604             (done () (return (cons (subseq string 0 end) list))))
605        (loop
606          :for start = (if (and max (>= words (1- max)))
607                           (done)
608                           (position-if #'separatorp string :end end :from-end t)) :do
609          (when (null start)
610            (done))
611          (push (subseq string (1+ start) end) list)
612          (incf words)
613          (setf end start))))))
614
615(defun* split-name-type (filename)
616  (let ((unspecific
617         ;; Giving :unspecific as argument to make-pathname is not portable.
618         ;; See CLHS make-pathname and 19.2.2.2.3.
619         ;; We only use it on implementations that support it.
620         (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
621    (destructuring-bind (name &optional (type unspecific))
622        (split-string filename :max 2 :separator ".")
623      (if (equal name "")
624          (values filename unspecific)
625          (values name type)))))
626
627(defun* component-name-to-pathname-components (s &key force-directory force-relative)
628  "Splits the path string S, returning three values:
629A flag that is either :absolute or :relative, indicating
630   how the rest of the values are to be interpreted.
631A directory path --- a list of strings, suitable for
632   use with MAKE-PATHNAME when prepended with the flag
633   value.
634A filename with type extension, possibly NIL in the
635   case of a directory pathname.
636FORCE-DIRECTORY forces S to be interpreted as a directory
637pathname \(third return value will be NIL, final component
638of S will be treated as part of the directory path.
639
640The intention of this function is to support structured component names,
641e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
642pathnames."
643  (check-type s string)
644  (when (find #\: s)
645    (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
646  (let* ((components (split-string s :separator "/"))
647         (last-comp (car (last components))))
648    (multiple-value-bind (relative components)
649        (if (equal (first components) "")
650            (if (equal (first-char s) #\/)
651                (progn
652                  (when force-relative
653                    (error "absolute pathname designator not allowed: ~S" s))
654                  (values :absolute (cdr components)))
655                (values :relative nil))
656          (values :relative components))
657      (setf components (remove "" components :test #'equal))
658      (cond
659        ((equal last-comp "")
660         (values relative components nil)) ; "" already removed
661        (force-directory
662         (values relative components nil))
663        (t
664         (values relative (butlast components) last-comp))))))
665
666(defun* remove-keys (key-names args)
667  (loop :for (name val) :on args :by #'cddr
668    :unless (member (symbol-name name) key-names
669                    :key #'symbol-name :test 'equal)
670    :append (list name val)))
671
672(defun* remove-keyword (key args)
673  (loop :for (k v) :on args :by #'cddr
674    :unless (eq k key)
675    :append (list k v)))
676
677(defun* getenv (x)
678  (#+abcl ext:getenv
679   #+allegro sys:getenv
680   #+clisp ext:getenv
681   #+clozure ccl:getenv
682   #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
683   #+ecl si:getenv
684   #+gcl system:getenv
685   #+lispworks lispworks:environment-variable
686   #+sbcl sb-ext:posix-getenv
687   x))
688
689(defun* directory-pathname-p (pathname)
690  "Does PATHNAME represent a directory?
691
692A directory-pathname is a pathname _without_ a filename. The three
693ways that the filename components can be missing are for it to be NIL,
694:UNSPECIFIC or the empty string.
695
696Note that this does _not_ check to see that PATHNAME points to an
697actually-existing directory."
698  (when pathname
699    (let ((pathname (pathname pathname)))
700      (flet ((check-one (x)
701               (member x '(nil :unspecific "") :test 'equal)))
702        (and (not (wild-pathname-p pathname))
703             (check-one (pathname-name pathname))
704             (check-one (pathname-type pathname))
705             t)))))
706
707(defun* ensure-directory-pathname (pathspec)
708  "Converts the non-wild pathname designator PATHSPEC to directory form."
709  (cond
710   ((stringp pathspec)
711    (ensure-directory-pathname (pathname pathspec)))
712   ((not (pathnamep pathspec))
713    (error "Invalid pathname designator ~S" pathspec))
714   ((wild-pathname-p pathspec)
715    (error "Can't reliably convert wild pathname ~S" pathspec))
716   ((directory-pathname-p pathspec)
717    pathspec)
718   (t
719    (make-pathname :directory (append (or (pathname-directory pathspec)
720                                          (list :relative))
721                                      (list (file-namestring pathspec)))
722                   :name nil :type nil :version nil
723                   :defaults pathspec))))
724
725(defun* absolute-pathname-p (pathspec)
726  (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
727
728(defun* length=n-p (x n) ;is it that (= (length x) n) ?
729  (check-type n (integer 0 *))
730  (loop
731    :for l = x :then (cdr l)
732    :for i :downfrom n :do
733    (cond
734      ((zerop i) (return (null l)))
735      ((not (consp l)) (return nil)))))
736
737(defun* ends-with (s suffix)
738  (check-type s string)
739  (check-type suffix string)
740  (let ((start (- (length s) (length suffix))))
741    (and (<= 0 start)
742         (string-equal s suffix :start1 start))))
743
744(defun* read-file-forms (file)
745  (with-open-file (in file)
746    (loop :with eof = (list nil)
747     :for form = (read in nil eof)
748     :until (eq form eof)
749     :collect form)))
750
751#-(and (or win32 windows mswindows mingw32) (not cygwin))
752(progn
753  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
754                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
755  (defun* get-uid ()
756    #+allegro (excl.osi:getuid)
757    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
758                  :for f = (ignore-errors (read-from-string s))
759                  :when f :return (funcall f))
760    #+(or cmu scl) (unix:unix-getuid)
761    #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
762                   '(ffi:c-inline () () :int "getuid()" :one-liner t)
763                   '(ext::getuid))
764    #+sbcl (sb-unix:unix-getuid)
765    #-(or allegro clisp cmu ecl sbcl scl)
766    (let ((uid-string
767           (with-output-to-string (*verbose-out*)
768             (run-shell-command "id -ur"))))
769      (with-input-from-string (stream uid-string)
770        (read-line stream)
771        (handler-case (parse-integer (read-line stream))
772          (error () (error "Unable to find out user ID")))))))
773
774(defun* pathname-root (pathname)
775  (make-pathname :host (pathname-host pathname)
776                 :device (pathname-device pathname)
777                 :directory '(:absolute)
778                 :name nil :type nil :version nil))
779
780(defun* probe-file* (p)
781  "when given a pathname P, probes the filesystem for a file or directory
782with given pathname and if it exists return its truename."
783  (etypecase p
784   (null nil)
785   (string (probe-file* (parse-namestring p)))
786   (pathname (unless (wild-pathname-p p)
787               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
788               #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
789               '(ignore-errors (truename p)))))))
790
791(defun* truenamize (p)
792  "Resolve as much of a pathname as possible"
793  (block nil
794    (when (typep p 'logical-pathname) (return p))
795    (let* ((p (merge-pathnames* p))
796           (directory (pathname-directory p)))
797      (when (typep p 'logical-pathname) (return p))
798      (let ((found (probe-file* p)))
799        (when found (return found)))
800      #-(or sbcl cmu) (when (stringp directory) (return p))
801      (when (not (eq :absolute (car directory))) (return p))
802      (let ((sofar (probe-file* (pathname-root p))))
803        (unless sofar (return p))
804        (flet ((solution (directories)
805                 (merge-pathnames*
806                  (make-pathname :host nil :device nil
807                                 :directory `(:relative ,@directories)
808                                 :name (pathname-name p)
809                                 :type (pathname-type p)
810                                 :version (pathname-version p))
811                  sofar)))
812          (loop :for component :in (cdr directory)
813            :for rest :on (cdr directory)
814            :for more = (probe-file*
815                         (merge-pathnames*
816                          (make-pathname :directory `(:relative ,component))
817                          sofar)) :do
818            (if more
819                (setf sofar more)
820                (return (solution rest)))
821            :finally
822            (return (solution nil))))))))
823
824(defun* resolve-symlinks (path)
825  #-allegro (truenamize path)
826  #+allegro (excl:pathname-resolve-symbolic-links path))
827
828(defun* default-directory ()
829  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
830
831(defun* lispize-pathname (input-file)
832  (make-pathname :type "lisp" :defaults input-file))
833
834(defparameter *wild-path*
835  (make-pathname :directory '(:relative :wild-inferiors)
836                 :name :wild :type :wild :version :wild))
837
838(defun* wilden (path)
839  (merge-pathnames* *wild-path* path))
840
841(defun* directorize-pathname-host-device (pathname)
842  (let* ((root (pathname-root pathname))
843         (wild-root (wilden root))
844         (absolute-pathname (merge-pathnames* pathname root))
845         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
846         (separator (last-char (namestring foo)))
847         (root-namestring (namestring root))
848         (root-string
849          (substitute-if #\/
850                         (lambda (x) (or (eql x #\:)
851                                         (eql x separator)))
852                         root-namestring)))
853    (multiple-value-bind (relative path filename)
854        (component-name-to-pathname-components root-string :force-directory t)
855      (declare (ignore relative filename))
856      (let ((new-base
857             (make-pathname :defaults root
858                            :directory `(:absolute ,@path))))
859        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
860
861;;;; -------------------------------------------------------------------------
862;;;; Classes, Conditions
863
864(define-condition system-definition-error (error) ()
865  ;; [this use of :report should be redundant, but unfortunately it's not.
866  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
867  ;; over print-object; this is always conditions::%print-condition for
868  ;; condition objects, which in turn does inheritance of :report options at
869  ;; run-time.  fortunately, inheritance means we only need this kludge here in
870  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
871  #+cmu (:report print-object))
872
873(declaim (ftype (function (t) t)
874                format-arguments format-control
875                error-name error-pathname error-condition
876                duplicate-names-name
877                error-component error-operation
878                module-components module-components-by-name
879                circular-dependency-components)
880         (ftype (function (t t) t) (setf module-components-by-name)))
881
882
883(define-condition formatted-system-definition-error (system-definition-error)
884  ((format-control :initarg :format-control :reader format-control)
885   (format-arguments :initarg :format-arguments :reader format-arguments))
886  (:report (lambda (c s)
887             (apply #'format s (format-control c) (format-arguments c)))))
888
889(define-condition load-system-definition-error (system-definition-error)
890  ((name :initarg :name :reader error-name)
891   (pathname :initarg :pathname :reader error-pathname)
892   (condition :initarg :condition :reader error-condition))
893  (:report (lambda (c s)
894             (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
895                     (error-name c) (error-pathname c) (error-condition c)))))
896
897(define-condition circular-dependency (system-definition-error)
898  ((components :initarg :components :reader circular-dependency-components))
899  (:report (lambda (c s)
900             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
901
902(define-condition duplicate-names (system-definition-error)
903  ((name :initarg :name :reader duplicate-names-name))
904  (:report (lambda (c s)
905             (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
906                     (duplicate-names-name c)))))
907
908(define-condition missing-component (system-definition-error)
909  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
910   (parent :initform nil :reader missing-parent :initarg :parent)))
911
912(define-condition missing-component-of-version (missing-component)
913  ((version :initform nil :reader missing-version :initarg :version)))
914
915(define-condition missing-dependency (missing-component)
916  ((required-by :initarg :required-by :reader missing-required-by)))
917
918(define-condition missing-dependency-of-version (missing-dependency
919                                                 missing-component-of-version)
920  ())
921
922(define-condition operation-error (error)
923  ((component :reader error-component :initarg :component)
924   (operation :reader error-operation :initarg :operation))
925  (:report (lambda (c s)
926             (format s "~@<erred while invoking ~A on ~A~@:>"
927                     (error-operation c) (error-component c)))))
928(define-condition compile-error (operation-error) ())
929(define-condition compile-failed (compile-error) ())
930(define-condition compile-warned (compile-error) ())
931
932(defclass component ()
933  ((name :accessor component-name :initarg :name :documentation
934         "Component name: designator for a string composed of portable pathname characters")
935   (version :accessor component-version :initarg :version)
936   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
937   ;; POIU is a parallel (multi-process build) extension of ASDF.  See
938   ;; http://www.cliki.net/poiu
939   (load-dependencies :accessor component-load-dependencies :initform nil)
940   ;; In the ASDF object model, dependencies exist between *actions*
941   ;; (an action is a pair of operation and component). They are represented
942   ;; alists of operations to dependencies (other actions) in each component.
943   ;; There are two kinds of dependencies, each stored in its own slot:
944   ;; in-order-to and do-first dependencies. These two kinds are related to
945   ;; the fact that some actions modify the filesystem,
946   ;; whereas other actions modify the current image, and
947   ;; this implies a difference in how to interpret timestamps.
948   ;; in-order-to dependencies will trigger re-performing the action
949   ;; when the timestamp of some dependency
950   ;; makes the timestamp of current action out-of-date;
951   ;; do-first dependencies do not trigger such re-performing.
952   ;; Therefore, a FASL must be recompiled if it is obsoleted
953   ;; by any of its FASL dependencies (in-order-to); but
954   ;; it needn't be recompiled just because one of these dependencies
955   ;; hasn't yet been loaded in the current image (do-first).
956   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
957   (in-order-to :initform nil :initarg :in-order-to
958                :accessor component-in-order-to)
959   (do-first :initform nil :initarg :do-first
960             :accessor component-do-first)
961   ;; methods defined using the "inline" style inside a defsystem form:
962   ;; need to store them somewhere so we can delete them when the system
963   ;; is re-evaluated
964   (inline-methods :accessor component-inline-methods :initform nil)
965   (parent :initarg :parent :initform nil :reader component-parent)
966   ;; no direct accessor for pathname, we do this as a method to allow
967   ;; it to default in funky ways if not supplied
968   (relative-pathname :initarg :pathname)
969   (absolute-pathname)
970   (operation-times :initform (make-hash-table)
971                    :accessor component-operation-times)
972   ;; XXX we should provide some atomic interface for updating the
973   ;; component properties
974   (properties :accessor component-properties :initarg :properties
975               :initform nil)))
976
977(defun* component-find-path (component)
978  (reverse
979   (loop :for c = component :then (component-parent c)
980     :while c :collect (component-name c))))
981
982(defmethod print-object ((c component) stream)
983  (print-unreadable-object (c stream :type t :identity nil)
984    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
985
986
987;;;; methods: conditions
988
989(defmethod print-object ((c missing-dependency) s)
990  (format s "~@<~A, required by ~A~@:>"
991          (call-next-method c nil) (missing-required-by c)))
992
993(defun* sysdef-error (format &rest arguments)
994  (error 'formatted-system-definition-error :format-control
995         format :format-arguments arguments))
996
997;;;; methods: components
998
999(defmethod print-object ((c missing-component) s)
1000  (format s "~@<component ~S not found~@[ in ~A~]~@:>"
1001          (missing-requires c)
1002          (when (missing-parent c)
1003            (component-name (missing-parent c)))))
1004
1005(defmethod print-object ((c missing-component-of-version) s)
1006  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
1007          (missing-requires c)
1008          (missing-version c)
1009          (when (missing-parent c)
1010            (component-name (missing-parent c)))))
1011
1012(defmethod component-system ((component component))
1013  (aif (component-parent component)
1014       (component-system it)
1015       component))
1016
1017(defvar *default-component-class* 'cl-source-file)
1018
1019(defun* compute-module-components-by-name (module)
1020  (let ((hash (make-hash-table :test 'equal)))
1021    (setf (module-components-by-name module) hash)
1022    (loop :for c :in (module-components module)
1023      :for name = (component-name c)
1024      :for previous = (gethash name (module-components-by-name module))
1025      :do
1026      (when previous
1027        (error 'duplicate-names :name name))
1028      :do (setf (gethash name (module-components-by-name module)) c))
1029    hash))
1030
1031(defclass module (component)
1032  ((components
1033    :initform nil
1034    :initarg :components
1035    :accessor module-components)
1036   (components-by-name
1037    :accessor module-components-by-name)
1038   ;; What to do if we can't satisfy a dependency of one of this module's
1039   ;; components.  This allows a limited form of conditional processing.
1040   (if-component-dep-fails
1041    :initform :fail
1042    :initarg :if-component-dep-fails
1043    :accessor module-if-component-dep-fails)
1044   (default-component-class
1045    :initform *default-component-class*
1046    :initarg :default-component-class
1047    :accessor module-default-component-class)))
1048
1049(defun* component-parent-pathname (component)
1050  ;; No default anymore (in particular, no *default-pathname-defaults*).
1051  ;; If you force component to have a NULL pathname, you better arrange
1052  ;; for any of its children to explicitly provide a proper absolute pathname
1053  ;; wherever a pathname is actually wanted.
1054  (let ((parent (component-parent component)))
1055    (when parent
1056      (component-pathname parent))))
1057
1058(defmethod component-pathname ((component component))
1059  (if (slot-boundp component 'absolute-pathname)
1060      (slot-value component 'absolute-pathname)
1061      (let ((pathname
1062             (merge-pathnames*
1063             (component-relative-pathname component)
1064             (pathname-directory-pathname (component-parent-pathname component)))))
1065        (unless (or (null pathname) (absolute-pathname-p pathname))
1066          (error "Invalid relative pathname ~S for component ~S"
1067                 pathname (component-find-path component)))
1068        (setf (slot-value component 'absolute-pathname) pathname)
1069        pathname)))
1070
1071(defmethod component-property ((c component) property)
1072  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
1073
1074(defmethod (setf component-property) (new-value (c component) property)
1075  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
1076    (if a
1077        (setf (cdr a) new-value)
1078        (setf (slot-value c 'properties)
1079              (acons property new-value (slot-value c 'properties)))))
1080  new-value)
1081
1082(defclass system (module)
1083  ((description :accessor system-description :initarg :description)
1084   (long-description
1085    :accessor system-long-description :initarg :long-description)
1086   (author :accessor system-author :initarg :author)
1087   (maintainer :accessor system-maintainer :initarg :maintainer)
1088   (licence :accessor system-licence :initarg :licence
1089            :accessor system-license :initarg :license)
1090   (source-file :reader system-source-file :initarg :source-file
1091                :writer %set-system-source-file)
1092   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
1093
1094;;;; -------------------------------------------------------------------------
1095;;;; version-satisfies
1096
1097(defmethod version-satisfies ((c component) version)
1098  (unless (and version (slot-boundp c 'version))
1099    (return-from version-satisfies t))
1100  (version-satisfies (component-version c) version))
1101
1102(defmethod version-satisfies ((cver string) version)
1103  (let ((x (mapcar #'parse-integer
1104                   (split-string cver :separator ".")))
1105        (y (mapcar #'parse-integer
1106                   (split-string version :separator "."))))
1107    (labels ((bigger (x y)
1108               (cond ((not y) t)
1109                     ((not x) nil)
1110                     ((> (car x) (car y)) t)
1111                     ((= (car x) (car y))
1112                      (bigger (cdr x) (cdr y))))))
1113      (and (= (car x) (car y))
1114           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
1115
1116;;;; -------------------------------------------------------------------------
1117;;;; Finding systems
1118
1119(defun* make-defined-systems-table ()
1120  (make-hash-table :test 'equal))
1121
1122(defvar *defined-systems* (make-defined-systems-table)
1123  "This is a hash table whose keys are strings, being the
1124names of the systems, and whose values are pairs, the first
1125element of which is a universal-time indicating when the
1126system definition was last updated, and the second element
1127of which is a system object.")
1128
1129(defun* coerce-name (name)
1130  (typecase name
1131    (component (component-name name))
1132    (symbol (string-downcase (symbol-name name)))
1133    (string name)
1134    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
1135
1136(defun* system-registered-p (name)
1137  (gethash (coerce-name name) *defined-systems*))
1138
1139(defun* clear-system (name)
1140  "Clear the entry for a system in the database of systems previously loaded.
1141Note that this does NOT in any way cause the code of the system to be unloaded."
1142  ;; There is no "unload" operation in Common Lisp, and a general such operation
1143  ;; cannot be portably written, considering how much CL relies on side-effects
1144  ;; of global data structures.
1145  ;; Note that this does a setf gethash instead of a remhash
1146  ;; this way there remains a hint in the *defined-systems* table
1147  ;; that the system was loaded at some point.
1148  (setf (gethash (coerce-name name) *defined-systems*) nil))
1149
1150(defun* map-systems (fn)
1151  "Apply FN to each defined system.
1152
1153FN should be a function of one argument. It will be
1154called with an object of type asdf:system."
1155  (maphash (lambda (_ datum)
1156             (declare (ignore _))
1157             (destructuring-bind (_ . def) datum
1158               (declare (ignore _))
1159               (funcall fn def)))
1160           *defined-systems*))
1161
1162;;; for the sake of keeping things reasonably neat, we adopt a
1163;;; convention that functions in this list are prefixed SYSDEF-
1164
1165(defparameter *system-definition-search-functions*
1166  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
1167
1168(defun* system-definition-pathname (system)
1169  (let ((system-name (coerce-name system)))
1170    (or
1171     (some (lambda (x) (funcall x system-name))
1172           *system-definition-search-functions*)
1173     (let ((system-pair (system-registered-p system-name)))
1174       (and system-pair
1175            (system-source-file (cdr system-pair)))))))
1176
1177(defvar *central-registry* nil
1178"A list of 'system directory designators' ASDF uses to find systems.
1179
1180A 'system directory designator' is a pathname or an expression
1181which evaluates to a pathname. For example:
1182
1183    (setf asdf:*central-registry*
1184          (list '*default-pathname-defaults*
1185                #p\"/home/me/cl/systems/\"
1186                #p\"/usr/share/common-lisp/systems/\"))
1187
1188This is for backward compatibilily.
1189Going forward, we recommend new users should be using the source-registry.
1190")
1191
1192(defun* probe-asd (name defaults)
1193  (block nil
1194    (when (directory-pathname-p defaults)
1195      (let ((file
1196             (make-pathname
1197              :defaults defaults :version :newest :case :local
1198              :name name
1199              :type "asd")))
1200        (when (probe-file file)
1201          (return file)))
1202      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
1203      (let ((shortcut
1204             (make-pathname
1205              :defaults defaults :version :newest :case :local
1206              :name (concatenate 'string name ".asd")
1207              :type "lnk")))
1208        (when (probe-file shortcut)
1209          (let ((target (parse-windows-shortcut shortcut)))
1210            (when target
1211              (return (pathname target)))))))))
1212
1213(defun* sysdef-central-registry-search (system)
1214  (let ((name (coerce-name system))
1215        (to-remove nil)
1216        (to-replace nil))
1217    (block nil
1218      (unwind-protect
1219           (dolist (dir *central-registry*)
1220             (let ((defaults (eval dir)))
1221               (when defaults
1222                 (cond ((directory-pathname-p defaults)
1223                        (let ((file (probe-asd name defaults)))
1224                          (when file
1225                            (return file))))
1226                       (t
1227                        (restart-case
1228                            (let* ((*print-circle* nil)
1229                                   (message
1230                                    (format nil
1231                                            "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
1232                                            system dir defaults)))
1233                              (error message))
1234                          (remove-entry-from-registry ()
1235                            :report "Remove entry from *central-registry* and continue"
1236                            (push dir to-remove))
1237                          (coerce-entry-to-directory ()
1238                            :report (lambda (s)
1239                                      (format s "Coerce entry to ~a, replace ~a and continue."
1240                                              (ensure-directory-pathname defaults) dir))
1241                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
1242        ;; cleanup
1243        (dolist (dir to-remove)
1244          (setf *central-registry* (remove dir *central-registry*)))
1245        (dolist (pair to-replace)
1246          (let* ((current (car pair))
1247                 (new (cdr pair))
1248                 (position (position current *central-registry*)))
1249            (setf *central-registry*
1250                  (append (subseq *central-registry* 0 position)
1251                          (list new)
1252                          (subseq *central-registry* (1+ position))))))))))
1253
1254(defun* make-temporary-package ()
1255  (flet ((try (counter)
1256           (ignore-errors
1257             (make-package (format nil "~A~D" :asdf counter)
1258                           :use '(:cl :asdf)))))
1259    (do* ((counter 0 (+ counter 1))
1260          (package (try counter) (try counter)))
1261         (package package))))
1262
1263(defun* safe-file-write-date (pathname)
1264  ;; If FILE-WRITE-DATE returns NIL, it's possible that
1265  ;; the user or some other agent has deleted an input file.
1266  ;; Also, generated files will not exist at the time planning is done
1267  ;; and calls operation-done-p which calls safe-file-write-date.
1268  ;; So it is very possible that we can't get a valid file-write-date,
1269  ;; and we can survive and we will continue the planning
1270  ;; as if the file were very old.
1271  ;; (or should we treat the case in a different, special way?)
1272  (or (and pathname (probe-file pathname) (file-write-date pathname))
1273      (progn
1274        (when (and pathname *asdf-verbose*)
1275          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
1276                pathname))
1277        0)))
1278
1279(defmethod find-system (name &optional (error-p t))
1280  (find-system (coerce-name name) error-p))
1281
1282(defmethod find-system ((name string) &optional (error-p t))
1283  (catch 'find-system
1284    (let* ((in-memory (system-registered-p name))
1285           (on-disk (system-definition-pathname name)))
1286      (when (and on-disk
1287                 (or (not in-memory)
1288                     (< (car in-memory) (safe-file-write-date on-disk))))
1289        (let ((package (make-temporary-package)))
1290          (unwind-protect
1291               (handler-bind
1292                   ((error (lambda (condition)
1293                             (error 'load-system-definition-error
1294                                    :name name :pathname on-disk
1295                                    :condition condition))))
1296                 (let ((*package* package))
1297                   (asdf-message
1298                    "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
1299                    on-disk *package*)
1300                   (load on-disk)))
1301            (delete-package package))))
1302      (let ((in-memory (system-registered-p name)))
1303        (cond
1304          (in-memory
1305           (when on-disk
1306             (setf (car in-memory) (safe-file-write-date on-disk)))
1307           (cdr in-memory))
1308          (error-p
1309           (error 'missing-component :requires name)))))))
1310
1311(defun* register-system (name system)
1312  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
1313  (setf (gethash (coerce-name name) *defined-systems*)
1314        (cons (get-universal-time) system)))
1315
1316(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
1317  (setf fallback (coerce-name fallback)
1318        source-file (or source-file *compile-file-truename* *load-truename*)
1319        requested (coerce-name requested))
1320  (when (equal requested fallback)
1321    (let* ((registered (cdr (gethash fallback *defined-systems*)))
1322           (system (or registered
1323                       (apply 'make-instance 'system
1324                              :name fallback :source-file source-file keys))))
1325      (unless registered
1326        (register-system fallback system))
1327      (throw 'find-system system))))
1328
1329(defun* sysdef-find-asdf (name)
1330  (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
1331
1332
1333;;;; -------------------------------------------------------------------------
1334;;;; Finding components
1335
1336(defmethod find-component ((base string) path)
1337  (let ((s (find-system base nil)))
1338    (and s (find-component s path))))
1339
1340(defmethod find-component ((base symbol) path)
1341  (cond
1342    (base (find-component (coerce-name base) path))
1343    (path (find-component path nil))
1344    (t    nil)))
1345
1346(defmethod find-component ((base cons) path)
1347  (find-component (car base) (cons (cdr base) path)))
1348
1349(defmethod find-component ((module module) (name string))
1350  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
1351    (compute-module-components-by-name module))
1352  (values (gethash name (module-components-by-name module))))
1353
1354(defmethod find-component ((component component) (name symbol))
1355  (if name
1356      (find-component component (coerce-name name))
1357      component))
1358
1359(defmethod find-component ((module module) (name cons))
1360  (find-component (find-component module (car name)) (cdr name)))
1361
1362
1363;;; component subclasses
1364
1365(defclass source-file (component)
1366  ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
1367
1368(defclass cl-source-file (source-file)
1369  ((type :initform "lisp")))
1370(defclass c-source-file (source-file)
1371  ((type :initform "c")))
1372(defclass java-source-file (source-file)
1373  ((type :initform "java")))
1374(defclass static-file (source-file) ())
1375(defclass doc-file (static-file) ())
1376(defclass html-file (doc-file)
1377  ((type :initform "html")))
1378
1379(defmethod source-file-type ((component module) (s module))
1380  (declare (ignorable component s))
1381  :directory)
1382(defmethod source-file-type ((component source-file) (s module))
1383  (declare (ignorable s))
1384  (source-file-explicit-type component))
1385
1386(defun* merge-component-name-type (name &key type defaults)
1387  ;; The defaults are required notably because they provide the default host
1388  ;; to the below make-pathname, which may crucially matter to people using
1389  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
1390  ;; NOTE that the host and device slots will be taken from the defaults,
1391  ;; but that should only matter if you either (a) use absolute pathnames, or
1392  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
1393  ;; ASDF:MERGE-PATHNAMES*
1394  (etypecase name
1395    (pathname
1396     name)
1397    (symbol
1398     (merge-component-name-type (string-downcase name) :type type :defaults defaults))
1399    (string
1400     (multiple-value-bind (relative path filename)
1401         (component-name-to-pathname-components name :force-directory (eq type :directory)
1402                                                :force-relative t)
1403       (multiple-value-bind (name type)
1404           (cond
1405             ((or (eq type :directory) (null filename))
1406              (values nil nil))
1407             (type
1408              (values filename type))
1409             (t
1410              (split-name-type filename)))
1411         (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
1412                (host (pathname-host defaults))
1413                (device (pathname-device defaults)))
1414           (make-pathname :directory `(,relative ,@path)
1415                          :name name :type type
1416                          :host host :device device)))))))
1417
1418(defmethod component-relative-pathname ((component component))
1419  (merge-component-name-type
1420   (or (slot-value component 'relative-pathname)
1421       (component-name component))
1422   :type (source-file-type component (component-system component))
1423   :defaults (component-parent-pathname component)))
1424
1425;;;; -------------------------------------------------------------------------
1426;;;; Operations
1427
1428;;; one of these is instantiated whenever #'operate is called
1429
1430(defclass operation ()
1431  (
1432   ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
1433   ;; T to force the inside of existing system,
1434   ;;   but not recurse to other systems we depend on.
1435   ;; :ALL (or any other atom) to force all systems
1436   ;;   including other systems we depend on.
1437   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
1438   ;;   to force systems named in a given list
1439   ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
1440   (forced :initform nil :initarg :force :accessor operation-forced)
1441   (original-initargs :initform nil :initarg :original-initargs
1442                      :accessor operation-original-initargs)
1443   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
1444   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
1445   (parent :initform nil :initarg :parent :accessor operation-parent)))
1446
1447(defmethod print-object ((o operation) stream)
1448  (print-unreadable-object (o stream :type t :identity t)
1449    (ignore-errors
1450      (prin1 (operation-original-initargs o) stream))))
1451
1452(defmethod shared-initialize :after ((operation operation) slot-names
1453                                     &key force
1454                                     &allow-other-keys)
1455  (declare (ignorable operation slot-names force))
1456  ;; empty method to disable initarg validity checking
1457  (values))
1458
1459(defun* node-for (o c)
1460  (cons (class-name (class-of o)) c))
1461
1462(defmethod operation-ancestor ((operation operation))
1463  (aif (operation-parent operation)
1464       (operation-ancestor it)
1465       operation))
1466
1467
1468(defun* make-sub-operation (c o dep-c dep-o)
1469  "C is a component, O is an operation, DEP-C is another
1470component, and DEP-O, confusingly enough, is an operation
1471class specifier, not an operation."
1472  (let* ((args (copy-list (operation-original-initargs o)))
1473         (force-p (getf args :force)))
1474    ;; note explicit comparison with T: any other non-NIL force value
1475    ;; (e.g. :recursive) will pass through
1476    (cond ((and (null (component-parent c))
1477                (null (component-parent dep-c))
1478                (not (eql c dep-c)))
1479           (when (eql force-p t)
1480             (setf (getf args :force) nil))
1481           (apply #'make-instance dep-o
1482                  :parent o
1483                  :original-initargs args args))
1484          ((subtypep (type-of o) dep-o)
1485           o)
1486          (t
1487           (apply #'make-instance dep-o
1488                  :parent o :original-initargs args args)))))
1489
1490
1491(defmethod visit-component ((o operation) (c component) data)
1492  (unless (component-visited-p o c)
1493    (setf (gethash (node-for o c)
1494                   (operation-visited-nodes (operation-ancestor o)))
1495          (cons t data))))
1496
1497(defmethod component-visited-p ((o operation) (c component))
1498  (gethash (node-for o c)
1499           (operation-visited-nodes (operation-ancestor o))))
1500
1501(defmethod (setf visiting-component) (new-value operation component)
1502  ;; MCL complains about unused lexical variables
1503  (declare (ignorable operation component))
1504  new-value)
1505
1506(defmethod (setf visiting-component) (new-value (o operation) (c component))
1507  (let ((node (node-for o c))
1508        (a (operation-ancestor o)))
1509    (if new-value
1510        (setf (gethash node (operation-visiting-nodes a)) t)
1511        (remhash node (operation-visiting-nodes a)))
1512    new-value))
1513
1514(defmethod component-visiting-p ((o operation) (c component))
1515  (let ((node (node-for o c)))
1516    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
1517
1518(defmethod component-depends-on ((op-spec symbol) (c component))
1519  (component-depends-on (make-instance op-spec) c))
1520
1521(defmethod component-depends-on ((o operation) (c component))
1522  (cdr (assoc (class-name (class-of o))
1523              (component-in-order-to c))))
1524
1525(defmethod component-self-dependencies ((o operation) (c component))
1526  (let ((all-deps (component-depends-on o c)))
1527    (remove-if-not (lambda (x)
1528                     (member (component-name c) (cdr x) :test #'string=))
1529                   all-deps)))
1530
1531(defmethod input-files ((operation operation) (c component))
1532  (let ((parent (component-parent c))
1533        (self-deps (component-self-dependencies operation c)))
1534    (if self-deps
1535        (mapcan (lambda (dep)
1536                  (destructuring-bind (op name) dep
1537                    (output-files (make-instance op)
1538                                  (find-component parent name))))
1539                self-deps)
1540        ;; no previous operations needed?  I guess we work with the
1541        ;; original source file, then
1542        (list (component-pathname c)))))
1543
1544(defmethod input-files ((operation operation) (c module))
1545  (declare (ignorable operation c))
1546  nil)
1547
1548(defmethod component-operation-time (o c)
1549  (gethash (type-of o) (component-operation-times c)))
1550
1551(defmethod operation-done-p ((o operation) (c component))
1552  (let ((out-files (output-files o c))
1553        (in-files (input-files o c))
1554        (op-time (component-operation-time o c)))
1555    (flet ((earliest-out ()
1556             (reduce #'min (mapcar #'safe-file-write-date out-files)))
1557           (latest-in ()
1558             (reduce #'max (mapcar #'safe-file-write-date in-files))))
1559      (cond
1560        ((and (not in-files) (not out-files))
1561         ;; arbitrary decision: an operation that uses nothing to
1562         ;; produce nothing probably isn't doing much.
1563         ;; e.g. operations on systems, modules that have no immediate action,
1564         ;; but are only meaningful through traversed dependencies
1565         t)
1566        ((not out-files)
1567         ;; an operation without output-files is probably meant
1568         ;; for its side-effects in the current image,
1569         ;; assumed to be idem-potent,
1570         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
1571         (and op-time (>= op-time (latest-in))))
1572        ((not in-files)
1573         ;; an operation without output-files and no input-files
1574         ;; is probably meant for its side-effects on the file-system,
1575         ;; assumed to have to be done everytime.
1576         ;; (I don't think there is any such case in ASDF unless extended)
1577         nil)
1578        (t
1579         ;; an operation with both input and output files is assumed
1580         ;; as computing the latter from the former,
1581         ;; assumed to have been done if the latter are all older
1582         ;; than the former.
1583         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
1584         ;; We use >= instead of > to play nice with generated files.
1585         ;; This opens a race condition if an input file is changed
1586         ;; after the output is created but within the same second
1587         ;; of filesystem time; but the same race condition exists
1588         ;; whenever the computation from input to output takes more
1589         ;; than one second of filesystem time (or just crosses the
1590         ;; second). So that's cool.
1591         (and
1592          (every #'probe-file in-files)
1593          (every #'probe-file out-files)
1594          (>= (earliest-out) (latest-in))))))))
1595
1596
1597
1598;;; For 1.700 I've done my best to refactor TRAVERSE
1599;;; by splitting it up in a bunch of functions,
1600;;; so as to improve the collection and use-detection algorithm. --fare
1601;;; The protocol is as follows: we pass around operation, dependency,
1602;;; bunch of other stuff, and a force argument. Return a force flag.
1603;;; The returned flag is T if anything has changed that requires a rebuild.
1604;;; The force argument is a list of components that will require a rebuild
1605;;; if the flag is T, at which point whoever returns the flag has to
1606;;; mark them all as forced, and whoever recurses again can use a NIL list
1607;;; as a further argument.
1608
1609(defvar *forcing* nil
1610  "This dynamically-bound variable is used to force operations in
1611recursive calls to traverse.")
1612
1613(defgeneric* do-traverse (operation component collect))
1614
1615(defun* %do-one-dep (operation c collect required-op required-c required-v)
1616  ;; collects a partial plan that results from performing required-op
1617  ;; on required-c, possibly with a required-vERSION
1618  (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
1619                      (and d (version-satisfies d required-v) d))
1620                    (if required-v
1621                        (error 'missing-dependency-of-version
1622                               :required-by c
1623                               :version required-v
1624                               :requires required-c)
1625                        (error 'missing-dependency
1626                               :required-by c
1627                               :requires required-c))))
1628         (op (make-sub-operation c operation dep-c required-op)))
1629    (do-traverse op dep-c collect)))
1630
1631(defun* do-one-dep (operation c collect required-op required-c required-v)
1632  ;; this function is a thin, error-handling wrapper around %do-one-dep.
1633  ;; Collects a partial plan per that function.
1634  (loop
1635    (restart-case
1636        (return (%do-one-dep operation c collect
1637                             required-op required-c required-v))
1638      (retry ()
1639        :report (lambda (s)
1640                  (format s "~@<Retry loading component ~S.~@:>"
1641                          (component-find-path required-c)))
1642        :test
1643        (lambda (c)
1644          (or (null c)
1645              (and (typep c 'missing-dependency)
1646                   (equalp (missing-requires c)
1647                           required-c))))))))
1648
1649(defun* do-dep (operation c collect op dep)
1650  ;; type of arguments uncertain:
1651  ;; op seems to at least potentially be a symbol, rather than an operation
1652  ;; dep is a list of component names
1653  (cond ((eq op 'feature)
1654         (if (member (car dep) *features*)
1655             nil
1656             (error 'missing-dependency
1657                    :required-by c
1658                    :requires (car dep))))
1659        (t
1660         (let ((flag nil))
1661           (flet ((dep (op comp ver)
1662                    (when (do-one-dep operation c collect
1663                                      op comp ver)
1664                      (setf flag t))))
1665             (dolist (d dep)
1666               (if (atom d)
1667                   (dep op d nil)
1668                   ;; structured dependencies --- this parses keywords
1669                   ;; the keywords could be broken out and cleanly (extensibly)
1670                   ;; processed by EQL methods
1671                   (cond ((eq :version (first d))
1672                          ;; https://bugs.launchpad.net/asdf/+bug/527788
1673                          (dep op (second d) (third d)))
1674                         ;; This particular subform is not documented and
1675                         ;; has always been broken in the past.
1676                         ;; Therefore no one uses it, and I'm cerroring it out,
1677                         ;; after fixing it
1678                         ;; See https://bugs.launchpad.net/asdf/+bug/518467
1679                         ((eq :feature (first d))
1680                          (cerror "Continue nonetheless."
1681                                  "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
1682                          (when (find (second d) *features* :test 'string-equal)
1683                            (dep op (third d) nil)))
1684                         (t
1685                          (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
1686           flag))))
1687
1688(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
1689
1690(defun* do-collect (collect x)
1691  (funcall collect x))
1692
1693(defmethod do-traverse ((operation operation) (c component) collect)
1694  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
1695    (labels
1696        ((update-flag (x)
1697           (when x
1698             (setf flag t)))
1699         (dep (op comp)
1700           (update-flag (do-dep operation c collect op comp))))
1701      ;; Have we been visited yet? If so, just process the result.
1702      (aif (component-visited-p operation c)
1703           (progn
1704             (update-flag (cdr it))
1705             (return-from do-traverse flag)))
1706      ;; dependencies
1707      (when (component-visiting-p operation c)
1708        (error 'circular-dependency :components (list c)))
1709      (setf (visiting-component operation c) t)
1710      (unwind-protect
1711           (progn
1712             ;; first we check and do all the dependencies for the module.
1713             ;; Operations planned in this loop will show up
1714             ;; in the results, and are consumed below.
1715             (let ((*forcing* nil))
1716               ;; upstream dependencies are never forced to happen just because
1717               ;; the things that depend on them are....
1718               (loop
1719                 :for (required-op . deps) :in (component-depends-on operation c)
1720                 :do (dep required-op deps)))
1721             ;; constituent bits
1722             (let ((module-ops
1723                    (when (typep c 'module)
1724                      (let ((at-least-one nil)
1725                            ;; This is set based on the results of the
1726                            ;; dependencies and whether we are in the
1727                            ;; context of a *forcing* call...
1728                            ;; inter-system dependencies do NOT trigger
1729                            ;; building components
1730                            (*forcing*
1731                             (or *forcing*
1732                                 (and flag (not (typep c 'system)))))
1733                            (error nil))
1734                        (while-collecting (internal-collect)
1735                          (dolist (kid (module-components c))
1736                            (handler-case
1737                                (update-flag
1738                                 (do-traverse operation kid #'internal-collect))
1739                              (missing-dependency (condition)
1740                                (when (eq (module-if-component-dep-fails c)
1741                                          :fail)
1742                                  (error condition))
1743                                (setf error condition))
1744                              (:no-error (c)
1745                                (declare (ignore c))
1746                                (setf at-least-one t))))
1747                          (when (and (eq (module-if-component-dep-fails c)
1748                                         :try-next)
1749                                     (not at-least-one))
1750                            (error error)))))))
1751               (update-flag
1752                (or
1753                 *forcing*
1754                 (not (operation-done-p operation c))
1755                 ;; For sub-operations, check whether
1756                 ;; the original ancestor operation was forced,
1757                 ;; or names us amongst an explicit list of things to force...
1758                 ;; except that this check doesn't distinguish
1759                 ;; between all the things with a given name. Sigh.
1760                 ;; BROKEN!
1761                 (let ((f (operation-forced
1762                           (operation-ancestor operation))))
1763                   (and f (or (not (consp f)) ;; T or :ALL
1764                              (and (typep c 'system) ;; list of names of systems to force
1765                                   (member (component-name c) f
1766                                           :test #'string=)))))))
1767               (when flag
1768                 (let ((do-first (cdr (assoc (class-name (class-of operation))
1769                                             (component-do-first c)))))
1770                   (loop :for (required-op . deps) :in do-first
1771                     :do (do-dep operation c collect required-op deps)))
1772                 (do-collect collect (vector module-ops))
1773                 (do-collect collect (cons operation c)))))
1774             (setf (visiting-component operation c) nil)))
1775      (visit-component operation c (when flag (incf *visit-count*)))
1776      flag))
1777
1778(defun* flatten-tree (l)
1779  ;; You collected things into a list.
1780  ;; Most elements are just things to collect again.
1781  ;; A (simple-vector 1) indicate that you should recurse into its contents.
1782  ;; This way, in two passes (rather than N being the depth of the tree),
1783  ;; you can collect things with marginally constant-time append,
1784  ;; achieving linear time collection instead of quadratic time.
1785  (while-collecting (c)
1786    (labels ((r (x)
1787               (if (typep x '(simple-vector 1))
1788                   (r* (svref x 0))
1789                   (c x)))
1790             (r* (l)
1791               (dolist (x l) (r x))))
1792      (r* l))))
1793
1794(defmethod traverse ((operation operation) (c component))
1795  ;; cerror'ing a feature that seems to have NEVER EVER worked
1796  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
1797  ;; It was both fixed and disabled in the 1.700 rewrite.
1798  (when (consp (operation-forced operation))
1799    (cerror "Continue nonetheless."
1800            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
1801    (setf (operation-forced operation)
1802          (mapcar #'coerce-name (operation-forced operation))))
1803  (flatten-tree
1804   (while-collecting (collect)
1805     (let ((*visit-count* 0))
1806       (do-traverse operation c #'collect)))))
1807
1808(defmethod perform ((operation operation) (c source-file))
1809  (sysdef-error
1810   "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
1811   (class-of operation) (class-of c)))
1812
1813(defmethod perform ((operation operation) (c module))
1814  (declare (ignorable operation c))
1815  nil)
1816
1817(defmethod explain ((operation operation) (component component))
1818  (asdf-message "~&;;; ~A~%" (operation-description operation component)))
1819
1820(defmethod operation-description (operation component)
1821  (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
1822
1823;;;; -------------------------------------------------------------------------
1824;;;; compile-op
1825
1826(defclass compile-op (operation)
1827  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
1828   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
1829                :initform *compile-file-warnings-behaviour*)
1830   (on-failure :initarg :on-failure :accessor operation-on-failure
1831               :initform *compile-file-failure-behaviour*)
1832   (flags :initarg :flags :accessor compile-op-flags
1833          :initform #-ecl nil #+ecl '(:system-p t))))
1834
1835(defun output-file (operation component)
1836  "The unique output file of performing OPERATION on COMPONENT"
1837  (let ((files (output-files operation component)))
1838    (assert (length=n-p files 1))
1839    (first files)))
1840
1841(defmethod perform :before ((operation compile-op) (c source-file))
1842  (map nil #'ensure-directories-exist (output-files operation c)))
1843
1844#+ecl
1845(defmethod perform :after ((o compile-op) (c cl-source-file))
1846  ;; Note how we use OUTPUT-FILES to find the binary locations
1847  ;; This allows the user to override the names.
1848  (let* ((files (output-files o c))
1849         (object (first files))
1850         (fasl (second files)))
1851    (c:build-fasl fasl :lisp-files (list object))))
1852
1853(defmethod perform :after ((operation operation) (c component))
1854  (setf (gethash (type-of operation) (component-operation-times c))
1855        (get-universal-time)))
1856
1857(declaim (ftype (function ((or pathname string)
1858                           &rest t &key (:output-file t) &allow-other-keys)
1859                          (values t t t))
1860                compile-file*))
1861
1862;;; perform is required to check output-files to find out where to put
1863;;; its answers, in case it has been overridden for site policy
1864(defmethod perform ((operation compile-op) (c cl-source-file))
1865  #-:broken-fasl-loader
1866  (let ((source-file (component-pathname c))
1867        ;; on some implementations, there are more than one output-file,
1868        ;; but the first one should always be the primary fasl that gets loaded.
1869        (output-file (first (output-files operation c)))
1870        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
1871        (*compile-file-failure-behaviour* (operation-on-failure operation)))
1872    (multiple-value-bind (output warnings-p failure-p)
1873        (apply #'compile-file* source-file :output-file output-file
1874               (compile-op-flags operation))
1875      (when warnings-p
1876        (case (operation-on-warnings operation)
1877          (:warn (warn
1878                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
1879                  operation c))
1880          (:error (error 'compile-warned :component c :operation operation))
1881          (:ignore nil)))
1882      (when failure-p
1883        (case (operation-on-failure operation)
1884          (:warn (warn
1885                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
1886                  operation c))
1887          (:error (error 'compile-failed :component c :operation operation))
1888          (:ignore nil)))
1889      (unless output
1890        (error 'compile-error :component c :operation operation)))))
1891
1892(defmethod output-files ((operation compile-op) (c cl-source-file))
1893  (declare (ignorable operation))
1894  (let ((p (lispize-pathname (component-pathname c))))
1895    #-:broken-fasl-loader
1896    (list (compile-file-pathname p #+ecl :type #+ecl :object)
1897          #+ecl (compile-file-pathname p :type :fasl))
1898    #+:broken-fasl-loader (list p)))
1899
1900(defmethod perform ((operation compile-op) (c static-file))
1901  (declare (ignorable operation c))
1902  nil)
1903
1904(defmethod output-files ((operation compile-op) (c static-file))
1905  (declare (ignorable operation c))
1906  nil)
1907
1908(defmethod input-files ((operation compile-op) (c static-file))
1909  (declare (ignorable operation c))
1910  nil)
1911
1912(defmethod operation-description ((operation compile-op) component)
1913  (declare (ignorable operation))
1914  (format nil "compiling component ~S" (component-find-path component)))
1915
1916;;;; -------------------------------------------------------------------------
1917;;;; load-op
1918
1919(defclass basic-load-op (operation) ())
1920
1921(defclass load-op (basic-load-op) ())
1922
1923(defmethod perform ((o load-op) (c cl-source-file))
1924  (map () #'load
1925       #-ecl (input-files o c)
1926       #+ecl (loop :for i :in (input-files o c)
1927               :unless (string= (pathname-type i) "fas")
1928               :collect (compile-file-pathname (lispize-pathname i)))))
1929
1930(defmethod perform-with-restarts (operation component)
1931  (perform operation component))
1932
1933(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
1934  (declare (ignorable o))
1935  (loop :with state = :initial
1936    :until (or (eq state :success)
1937               (eq state :failure)) :do
1938    (case state
1939      (:recompiled
1940       (setf state :failure)
1941       (call-next-method)
1942       (setf state :success))
1943      (:failed-load
1944       (setf state :recompiled)
1945       (perform (make-instance 'compile-op) c))
1946      (t
1947       (with-simple-restart
1948           (try-recompiling "Recompile ~a and try loading it again"
1949                            (component-name c))
1950         (setf state :failed-load)
1951         (call-next-method)
1952         (setf state :success))))))
1953
1954(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
1955  (loop :with state = :initial
1956    :until (or (eq state :success)
1957               (eq state :failure)) :do
1958    (case state
1959      (:recompiled
1960       (setf state :failure)
1961       (call-next-method)
1962       (setf state :success))
1963      (:failed-compile
1964       (setf state :recompiled)
1965       (perform-with-restarts o c))
1966      (t
1967       (with-simple-restart
1968           (try-recompiling "Try recompiling ~a"
1969                            (component-name c))
1970         (setf state :failed-compile)
1971         (call-next-method)
1972         (setf state :success))))))
1973
1974(defmethod perform ((operation load-op) (c static-file))
1975  (declare (ignorable operation c))
1976  nil)
1977
1978(defmethod operation-done-p ((operation load-op) (c static-file))
1979  (declare (ignorable operation c))
1980  t)
1981
1982(defmethod output-files ((operation operation) (c component))
1983  (declare (ignorable operation c))
1984  nil)
1985
1986(defmethod component-depends-on ((operation load-op) (c component))
1987  (declare (ignorable operation))
1988  (cons (list 'compile-op (component-name c))
1989        (call-next-method)))
1990
1991(defmethod operation-description ((operation load-op) component)
1992  (declare (ignorable operation))
1993  (format nil "loading component ~S" (component-find-path component)))
1994
1995
1996;;;; -------------------------------------------------------------------------
1997;;;; load-source-op
1998
1999(defclass load-source-op (basic-load-op) ())
2000
2001(defmethod perform ((o load-source-op) (c cl-source-file))
2002  (declare (ignorable o))
2003  (let ((source (component-pathname c)))
2004    (setf (component-property c 'last-loaded-as-source)
2005          (and (load source)
2006               (get-universal-time)))))
2007
2008(defmethod perform ((operation load-source-op) (c static-file))
2009  (declare (ignorable operation c))
2010  nil)
2011
2012(defmethod output-files ((operation load-source-op) (c component))
2013  (declare (ignorable operation c))
2014  nil)
2015
2016;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
2017(defmethod component-depends-on ((o load-source-op) (c component))
2018  (declare (ignorable o))
2019  (let ((what-would-load-op-do (cdr (assoc 'load-op
2020                                           (component-in-order-to c)))))
2021    (mapcar (lambda (dep)
2022              (if (eq (car dep) 'load-op)
2023                  (cons 'load-source-op (cdr dep))
2024                  dep))
2025            what-would-load-op-do)))
2026
2027(defmethod operation-done-p ((o load-source-op) (c source-file))
2028  (declare (ignorable o))
2029  (if (or (not (component-property c 'last-loaded-as-source))
2030          (> (safe-file-write-date (component-pathname c))
2031             (component-property c 'last-loaded-as-source)))
2032      nil t))
2033
2034(defmethod operation-description ((operation load-source-op) component)
2035  (declare (ignorable operation))
2036  (format nil "loading component ~S" (component-find-path component)))
2037
2038
2039;;;; -------------------------------------------------------------------------
2040;;;; test-op
2041
2042(defclass test-op (operation) ())
2043
2044(defmethod perform ((operation test-op) (c component))
2045  (declare (ignorable operation c))
2046  nil)
2047
2048(defmethod operation-done-p ((operation test-op) (c system))
2049  "Testing a system is _never_ done."
2050  (declare (ignorable operation c))
2051  nil)
2052
2053(defmethod component-depends-on :around ((o test-op) (c system))
2054  (declare (ignorable o))
2055  (cons `(load-op ,(component-name c)) (call-next-method)))
2056
2057
2058;;;; -------------------------------------------------------------------------
2059;;;; Invoking Operations
2060
2061(defgeneric* operate (operation-class system &key &allow-other-keys))
2062
2063(defmethod operate (operation-class system &rest args
2064                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
2065                    &allow-other-keys)
2066  (declare (ignore force))
2067  (let* ((*package* *package*)
2068         (*readtable* *readtable*)
2069         (op (apply #'make-instance operation-class
2070                    :original-initargs args
2071                    args))
2072         (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
2073         (system (if (typep system 'component) system (find-system system))))
2074    (unless (version-satisfies system version)
2075      (error 'missing-component-of-version :requires system :version version))
2076    (let ((steps (traverse op system)))
2077      (with-compilation-unit ()
2078        (loop :for (op . component) :in steps :do
2079          (loop
2080            (restart-case
2081                (progn
2082                  (perform-with-restarts op component)
2083                  (return))
2084              (retry ()
2085                :report
2086                (lambda (s)
2087                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
2088              (accept ()
2089                :report
2090                (lambda (s)
2091                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
2092                          (operation-description op component)))
2093                (setf (gethash (type-of op)
2094                               (component-operation-times component))
2095                      (get-universal-time))
2096                (return))))))
2097      (values op steps))))
2098
2099(defun* oos (operation-class system &rest args &key force verbose version
2100            &allow-other-keys)
2101  (declare (ignore force verbose version))
2102  (apply #'operate operation-class system args))
2103
2104(let ((operate-docstring
2105  "Operate does three things:
2106
21071. It creates an instance of OPERATION-CLASS using any keyword parameters
2108as initargs.
21092. It finds the  asdf-system specified by SYSTEM (possibly loading
2110it from disk).
21113. It then calls TRAVERSE with the operation and system as arguments
2112
2113The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
2114handling code. If a VERSION argument is supplied, then operate also
2115ensures that the system found satisfies it using the VERSION-SATISFIES
2116method.
2117
2118Note that dependencies may cause the operation to invoke other
2119operations on the system or its components: the new operations will be
2120created with the same initargs as the original one.
2121"))
2122  (setf (documentation 'oos 'function)
2123        (format nil
2124                "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
2125                operate-docstring))
2126  (setf (documentation 'operate 'function)
2127        operate-docstring))
2128
2129(defun* load-system (system &rest args &key force verbose version
2130                    &allow-other-keys)
2131  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
2132details."
2133  (declare (ignore force verbose version))
2134  (apply #'operate 'load-op system args)
2135  t)
2136
2137(defun* compile-system (system &rest args &key force verbose version
2138                       &allow-other-keys)
2139  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
2140for details."
2141  (declare (ignore force verbose version))
2142  (apply #'operate 'compile-op system args)
2143  t)
2144
2145(defun* test-system (system &rest args &key force verbose version
2146                    &allow-other-keys)
2147  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
2148details."
2149  (declare (ignore force verbose version))
2150  (apply #'operate 'test-op system args)
2151  t)
2152
2153;;;; -------------------------------------------------------------------------
2154;;;; Defsystem
2155
2156(defun* load-pathname ()
2157  (let ((pn (or *load-pathname* *compile-file-pathname*)))
2158    (if *resolve-symlinks*
2159        (and pn (resolve-symlinks pn))
2160        pn)))
2161
2162(defun* determine-system-pathname (pathname pathname-supplied-p)
2163  ;; The defsystem macro calls us to determine
2164  ;; the pathname of a system as follows:
2165  ;; 1. the one supplied,
2166  ;; 2. derived from *load-pathname* via load-pathname
2167  ;; 3. taken from the *default-pathname-defaults* via default-directory
2168  (let* ((file-pathname (load-pathname))
2169         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
2170    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
2171        directory-pathname
2172        (default-directory))))
2173
2174(defmacro defsystem (name &body options)
2175  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
2176                            defsystem-depends-on &allow-other-keys)
2177      options
2178    (let ((component-options (remove-keys '(:class) options)))
2179      `(progn
2180         ;; system must be registered before we parse the body, otherwise
2181         ;; we recur when trying to find an existing system of the same name
2182         ;; to reuse options (e.g. pathname) from
2183         ,@(loop :for system :in defsystem-depends-on
2184             :collect `(load-system ,system))
2185         (let ((s (system-registered-p ',name)))
2186           (cond ((and s (eq (type-of (cdr s)) ',class))
2187                  (setf (car s) (get-universal-time)))
2188                 (s
2189                  (change-class (cdr s) ',class))
2190                 (t
2191                  (register-system (quote ,name)
2192                                   (make-instance ',class :name ',name))))
2193           (%set-system-source-file (load-pathname)
2194                                    (cdr (system-registered-p ',name))))
2195         (parse-component-form
2196          nil (list*
2197               :module (coerce-name ',name)
2198               :pathname
2199               ,(determine-system-pathname pathname pathname-arg-p)
2200               ',component-options))))))
2201
2202(defun* class-for-type (parent type)
2203  (or (loop :for symbol :in (list
2204                             (unless (keywordp type) type)
2205                             (find-symbol (symbol-name type) *package*)
2206                             (find-symbol (symbol-name type) :asdf))
2207        :for class = (and symbol (find-class symbol nil))
2208        :when (and class (subtypep class 'component))
2209        :return class)
2210      (and (eq type :file)
2211           (or (module-default-component-class parent)
2212               (find-class *default-component-class*)))
2213      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
2214
2215(defun* maybe-add-tree (tree op1 op2 c)
2216  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
2217Returns the new tree (which probably shares structure with the old one)"
2218  (let ((first-op-tree (assoc op1 tree)))
2219    (if first-op-tree
2220        (progn
2221          (aif (assoc op2 (cdr first-op-tree))
2222               (if (find c (cdr it))
2223                   nil
2224                   (setf (cdr it) (cons c (cdr it))))
2225               (setf (cdr first-op-tree)
2226                     (acons op2 (list c) (cdr first-op-tree))))
2227          tree)
2228        (acons op1 (list (list op2 c)) tree))))
2229
2230(defun* union-of-dependencies (&rest deps)
2231  (let ((new-tree nil))
2232    (dolist (dep deps)
2233      (dolist (op-tree dep)
2234        (dolist (op  (cdr op-tree))
2235          (dolist (c (cdr op))
2236            (setf new-tree
2237                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
2238    new-tree))
2239
2240
2241(defvar *serial-depends-on* nil)
2242
2243(defun* sysdef-error-component (msg type name value)
2244  (sysdef-error (concatenate 'string msg
2245                             "~&The value specified for ~(~A~) ~A is ~S")
2246                type name value))
2247
2248(defun* check-component-input (type name weakly-depends-on
2249                              depends-on components in-order-to)
2250  "A partial test of the values of a component."
2251  (unless (listp depends-on)
2252    (sysdef-error-component ":depends-on must be a list."
2253                            type name depends-on))
2254  (unless (listp weakly-depends-on)
2255    (sysdef-error-component ":weakly-depends-on must be a list."
2256                            type name weakly-depends-on))
2257  (unless (listp components)
2258    (sysdef-error-component ":components must be NIL or a list of components."
2259                            type name components))
2260  (unless (and (listp in-order-to) (listp (car in-order-to)))
2261    (sysdef-error-component ":in-order-to must be NIL or a list of components."
2262                            type name in-order-to)))
2263
2264(defun* %remove-component-inline-methods (component)
2265  (dolist (name +asdf-methods+)
2266    (map ()
2267         ;; this is inefficient as most of the stored
2268         ;; methods will not be for this particular gf
2269         ;; But this is hardly performance-critical
2270         (lambda (m)
2271           (remove-method (symbol-function name) m))
2272         (component-inline-methods component)))
2273  ;; clear methods, then add the new ones
2274  (setf (component-inline-methods component) nil))
2275
2276(defun* %define-component-inline-methods (ret rest)
2277  (dolist (name +asdf-methods+)
2278    (let ((keyword (intern (symbol-name name) :keyword)))
2279      (loop :for data = rest :then (cddr data)
2280        :for key = (first data)
2281        :for value = (second data)
2282        :while data
2283        :when (eq key keyword) :do
2284        (destructuring-bind (op qual (o c) &body body) value
2285          (pushnew
2286           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
2287                             ,@body))
2288           (component-inline-methods ret)))))))
2289
2290(defun* %refresh-component-inline-methods (component rest)
2291  (%remove-component-inline-methods component)
2292  (%define-component-inline-methods component rest))
2293
2294(defun* parse-component-form (parent options)
2295  (destructuring-bind
2296        (type name &rest rest &key
2297              ;; the following list of keywords is reproduced below in the
2298              ;; remove-keys form.  important to keep them in sync
2299              components pathname default-component-class
2300              perform explain output-files operation-done-p
2301              weakly-depends-on
2302              depends-on serial in-order-to
2303              ;; list ends
2304              &allow-other-keys) options
2305    (declare (ignorable perform explain output-files operation-done-p))
2306    (check-component-input type name weakly-depends-on depends-on components in-order-to)
2307
2308    (when (and parent
2309               (find-component parent name)
2310               ;; ignore the same object when rereading the defsystem
2311               (not
2312                (typep (find-component parent name)
2313                       (class-for-type parent type))))
2314      (error 'duplicate-names :name name))
2315
2316    (let* ((other-args (remove-keys
2317                        '(components pathname default-component-class
2318                          perform explain output-files operation-done-p
2319                          weakly-depends-on
2320                          depends-on serial in-order-to)
2321                        rest))
2322           (ret
2323            (or (find-component parent name)
2324                (make-instance (class-for-type parent type)))))
2325      (when weakly-depends-on
2326        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
2327      (when *serial-depends-on*
2328        (push *serial-depends-on* depends-on))
2329      (apply #'reinitialize-instance ret
2330             :name (coerce-name name)
2331             :pathname pathname
2332             :parent parent
2333             other-args)
2334      (component-pathname ret) ; eagerly compute the absolute pathname
2335      (when (typep ret 'module)
2336        (setf (module-default-component-class ret)
2337              (or default-component-class
2338                  (and (typep parent 'module)
2339                       (module-default-component-class parent))))
2340        (let ((*serial-depends-on* nil))
2341          (setf (module-components ret)
2342                (loop
2343                  :for c-form :in components
2344                  :for c = (parse-component-form ret c-form)
2345                  :for name = (component-name c)
2346                  :collect c
2347                  :when serial :do (setf *serial-depends-on* name))))
2348        (compute-module-components-by-name ret))
2349
2350      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
2351
2352      (setf (component-in-order-to ret)
2353            (union-of-dependencies
2354             in-order-to
2355             `((compile-op (compile-op ,@depends-on))
2356               (load-op (load-op ,@depends-on)))))
2357      (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
2358
2359      (%refresh-component-inline-methods ret rest)
2360      ret)))
2361
2362;;;; ---------------------------------------------------------------------------
2363;;;; run-shell-command
2364;;;;
2365;;;; run-shell-command functions for other lisp implementations will be
2366;;;; gratefully accepted, if they do the same thing.
2367;;;; If the docstring is ambiguous, send a bug report.
2368;;;;
2369;;;; We probably should move this functionality to its own system and deprecate
2370;;;; use of it from the asdf package. However, this would break unspecified
2371;;;; existing software, so until a clear alternative exists, we can't deprecate
2372;;;; it, and even after it's been deprecated, we will support it for a few
2373;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
2374
2375(defun* run-shell-command (control-string &rest args)
2376  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
2377synchronously execute the result using a Bourne-compatible shell, with
2378output to *VERBOSE-OUT*.  Returns the shell's exit code."
2379  (let ((command (apply #'format nil control-string args)))
2380    (asdf-message "; $ ~A~%" command)
2381
2382    #+abcl
2383    (ext:run-shell-command command :output *verbose-out*)
2384
2385    #+allegro
2386    ;; will this fail if command has embedded quotes - it seems to work
2387    (multiple-value-bind (stdout stderr exit-code)
2388        (excl.osi:command-output
2389         (format nil "~a -c \"~a\""
2390                 #+mswindows "sh" #-mswindows "/bin/sh" command)
2391         :input nil :whole nil
2392         #+mswindows :show-window #+mswindows :hide)
2393      (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
2394      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
2395      exit-code)
2396
2397    #+clisp                     ;XXX not exactly *verbose-out*, I know
2398    (ext:run-shell-command  command :output :terminal :wait t)
2399
2400    #+clozure
2401    (nth-value 1
2402               (ccl:external-process-status
2403                (ccl:run-program "/bin/sh" (list "-c" command)
2404                                 :input nil :output *verbose-out*
2405                                 :wait t)))
2406
2407    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
2408    (si:system command)
2409
2410    #+gcl
2411    (lisp:system command)
2412
2413    #+lispworks
2414    (system:call-system-showing-output
2415     command
2416     :shell-type "/bin/sh"
2417     :show-cmd nil
2418     :prefix ""
2419     :output-stream *verbose-out*)
2420
2421    #+sbcl
2422    (sb-ext:process-exit-code
2423     (apply #'sb-ext:run-program
2424            #+win32 "sh" #-win32 "/bin/sh"
2425            (list  "-c" command)
2426            :input nil :output *verbose-out*
2427            #+win32 '(:search t) #-win32 nil))
2428
2429    #+(or cmu scl)
2430    (ext:process-exit-code
2431     (ext:run-program
2432      "/bin/sh"
2433      (list  "-c" command)
2434      :input nil :output *verbose-out*))
2435
2436    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
2437    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
2438
2439;;;; ---------------------------------------------------------------------------
2440;;;; system-relative-pathname
2441
2442(defmethod system-source-file ((system-name string))
2443  (system-source-file (find-system system-name)))
2444(defmethod system-source-file ((system-name symbol))
2445  (system-source-file (find-system system-name)))
2446
2447(defun* system-source-directory (system-designator)
2448  "Return a pathname object corresponding to the
2449directory in which the system specification (.asd file) is
2450located."
2451     (make-pathname :name nil
2452                 :type nil
2453                 :defaults (system-source-file system-designator)))
2454
2455(defun* relativize-directory (directory)
2456  (cond
2457    ((stringp directory)
2458     (list :relative directory))
2459    ((eq (car directory) :absolute)
2460     (cons :relative (cdr directory)))
2461    (t
2462     directory)))
2463
2464(defun* relativize-pathname-directory (pathspec)
2465  (let ((p (pathname pathspec)))
2466    (make-pathname
2467     :directory (relativize-directory (pathname-directory p))
2468     :defaults p)))
2469
2470(defun* system-relative-pathname (system name &key type)
2471  (merge-pathnames*
2472   (merge-component-name-type name :type type)
2473   (system-source-directory system)))
2474
2475
2476;;; ---------------------------------------------------------------------------
2477;;; implementation-identifier
2478;;;
2479;;; produce a string to identify current implementation.
2480;;; Initially stolen from SLIME's SWANK, hacked since.
2481
2482(defparameter *implementation-features*
2483  '((:acl :allegro)
2484    (:lw :lispworks)
2485    (:digitool) ; before clozure, so it won't get preempted by ccl
2486    (:ccl :clozure)
2487    (:corman :cormanlisp)
2488    (:abcl :armedbear)
2489    :sbcl :cmu :clisp :gcl :ecl :scl))
2490
2491(defparameter *os-features*
2492  '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
2493    (:solaris :sunos)
2494    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
2495    (:macosx :darwin :darwin-target :apple)
2496    :freebsd :netbsd :openbsd :bsd
2497    :unix))
2498
2499(defparameter *architecture-features*
2500  '((:amd64 :x86-64 :x86_64 :x8664-target)
2501    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
2502    :hppa64
2503    :hppa
2504    (:ppc64 :ppc64-target)
2505    (:ppc32 :ppc32-target :ppc :powerpc)
2506    :sparc64
2507    (:sparc32 :sparc)
2508    (:arm :arm-target)
2509    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
2510
2511(defun* lisp-version-string ()
2512  (let ((s (lisp-implementation-version)))
2513    (declare (ignorable s))
2514    #+allegro (format nil
2515                      "~A~A~A~A"
2516                      excl::*common-lisp-version-number*
2517                      ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
2518                      (if (eq excl:*current-case-mode*
2519                              :case-sensitive-lower) "M" "A")
2520                      ;; Note if not using International ACL
2521                      ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
2522                      (excl:ics-target-case
2523                       (:-ics "8")
2524                       (:+ics ""))
2525                      (if (member :64bit *features*) "-64bit" ""))
2526    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
2527    #+clisp (subseq s 0 (position #\space s))
2528    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
2529                      ccl::*openmcl-major-version*
2530                      ccl::*openmcl-minor-version*
2531                      (logand ccl::fasl-version #xFF))
2532    #+cmu (substitute #\- #\/ s)
2533    #+digitool (subseq s 8)
2534    #+ecl (format nil "~A~@[-~A~]" s
2535                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
2536                    (when (>= (length vcs-id) 8)
2537                      (subseq vcs-id 0 8))))
2538    #+gcl (subseq s (1+ (position #\space s)))
2539    #+lispworks (format nil "~A~@[~A~]" s
2540                        (when (member :lispworks-64bit *features*) "-64bit"))
2541    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
2542    #+(or cormanlisp mcl sbcl scl) s
2543    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
2544          ecl gcl lispworks mcl sbcl scl) s))
2545
2546(defun* first-feature (features)
2547  (labels
2548      ((fp (thing)
2549         (etypecase thing
2550           (symbol
2551            (let ((feature (find thing *features*)))
2552              (when feature (return-from fp feature))))
2553           ;; allows features to be lists of which the first
2554           ;; member is the "main name", the rest being aliases
2555           (cons
2556            (dolist (subf thing)
2557              (when (find subf *features*) (return-from fp (first thing))))))
2558         nil))
2559    (loop :for f :in features
2560      :when (fp f) :return :it)))
2561
2562(defun* implementation-type ()
2563  (first-feature *implementation-features*))
2564
2565(defun* implementation-identifier ()
2566  (labels
2567      ((maybe-warn (value fstring &rest args)
2568         (cond (value)
2569               (t (apply #'warn fstring args)
2570                  "unknown"))))
2571    (let ((lisp (maybe-warn (implementation-type)
2572                            "No implementation feature found in ~a."
2573                            *implementation-features*))
2574          (os   (maybe-warn (first-feature *os-features*)
2575                            "No os feature found in ~a." *os-features*))
2576          (arch (maybe-warn (first-feature *architecture-features*)
2577                            "No architecture feature found in ~a."
2578                            *architecture-features*))
2579          (version (maybe-warn (lisp-version-string)
2580                               "Don't know how to get Lisp implementation version.")))
2581      (substitute-if
2582       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
2583       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
2584
2585
2586
2587;;; ---------------------------------------------------------------------------
2588;;; Generic support for configuration files
2589
2590(defparameter *inter-directory-separator*
2591  #+(or unix cygwin) #\:
2592  #-(or unix cygwin) #\;)
2593
2594(defun* user-homedir ()
2595  (truename (user-homedir-pathname)))
2596
2597(defun* try-directory-subpath (x sub &key type)
2598  (let* ((p (and x (ensure-directory-pathname x)))
2599         (tp (and p (probe-file* p)))
2600         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
2601         (ts (and sp (probe-file* sp))))
2602    (and ts (values sp ts))))
2603(defun* user-configuration-directories ()
2604  (remove-if
2605   #'null
2606   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
2607     `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
2608       ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
2609           :for dir :in (split-string dirs :separator ":")
2610           :collect (try dir "common-lisp/"))
2611       #+(and (or win32 windows mswindows mingw32) (not cygwin))
2612        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
2613            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
2614           ,(try (getenv "APPDATA") "common-lisp/config/"))
2615       ,(try (user-homedir) ".config/common-lisp/")))))
2616(defun* system-configuration-directories ()
2617  (remove-if
2618   #'null
2619   (append
2620    #+(and (or win32 windows mswindows mingw32) (not cygwin))
2621    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
2622      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
2623           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
2624        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
2625    (list #p"/etc/common-lisp/"))))
2626(defun* in-first-directory (dirs x)
2627  (loop :for dir :in dirs
2628    :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
2629(defun* in-user-configuration-directory (x)
2630  (in-first-directory (user-configuration-directories) x))
2631(defun* in-system-configuration-directory (x)
2632  (in-first-directory (system-configuration-directories) x))
2633
2634(defun* configuration-inheritance-directive-p (x)
2635  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
2636    (or (member x kw)
2637        (and (length=n-p x 1) (member (car x) kw)))))
2638
2639(defun* validate-configuration-form (form tag directive-validator
2640                                    &optional (description tag))
2641  (unless (and (consp form) (eq (car form) tag))
2642    (error "Error: Form doesn't specify ~A ~S~%" description form))
2643  (loop :with inherit = 0
2644    :for directive :in (cdr form) :do
2645    (if (configuration-inheritance-directive-p directive)
2646        (incf inherit)
2647        (funcall directive-validator directive))
2648    :finally
2649    (unless (= inherit 1)
2650      (error "One and only one of ~S or ~S is required"
2651             :inherit-configuration :ignore-inherited-configuration)))
2652  form)
2653
2654(defun* validate-configuration-file (file validator description)
2655  (let ((forms (read-file-forms file)))
2656    (unless (length=n-p forms 1)
2657      (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
2658    (funcall validator (car forms))))
2659
2660(defun* hidden-file-p (pathname)
2661  (equal (first-char (pathname-name pathname)) #\.))
2662
2663(defun* validate-configuration-directory (directory tag validator)
2664  (let ((files (sort (ignore-errors
2665                       (remove-if
2666                        'hidden-file-p
2667                        (directory (make-pathname :name :wild :type "conf" :defaults directory)
2668                                   #+sbcl :resolve-symlinks #+sbcl nil)))
2669                     #'string< :key #'namestring)))
2670    `(,tag
2671      ,@(loop :for file :in files :append
2672          (mapcar validator (read-file-forms file)))
2673      :inherit-configuration)))
2674
2675
2676;;; ---------------------------------------------------------------------------
2677;;; asdf-output-translations
2678;;;
2679;;; this code is heavily inspired from
2680;;; asdf-binary-translations, common-lisp-controller and cl-launch.
2681;;; ---------------------------------------------------------------------------
2682
2683(defvar *output-translations* ()
2684  "Either NIL (for uninitialized), or a list of one element,
2685said element itself being a sorted list of mappings.
2686Each mapping is a pair of a source pathname and destination pathname,
2687and the order is by decreasing length of namestring of the source pathname.")
2688
2689(defvar *user-cache*
2690  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
2691    (or
2692     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
2693     #+(and (or win32 windows mswindows mingw32) (not cygwin))
2694     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
2695     '(:home ".cache" "common-lisp" :implementation))))
2696(defvar *system-cache*
2697  ;; No good default, plus there's a security problem
2698  ;; with other users messing with such directories.
2699  *user-cache*)
2700
2701(defun* output-translations ()
2702  (car *output-translations*))
2703
2704(defun* (setf output-translations) (new-value)
2705  (setf *output-translations*
2706        (list
2707         (stable-sort (copy-list new-value) #'>
2708                      :key (lambda (x)
2709                             (etypecase (car x)
2710                               ((eql t) -1)
2711                               (pathname
2712                                (length (pathname-directory (car x)))))))))
2713  new-value)
2714
2715(defun* output-translations-initialized-p ()
2716  (and *output-translations* t))
2717
2718(defun* clear-output-translations ()
2719  "Undoes any initialization of the output translations.
2720You might want to call that before you dump an image that would be resumed
2721with a different configuration, so the configuration would be re-read then."
2722  (setf *output-translations* '())
2723  (values))
2724
2725(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
2726                          (values (or null pathname) &optional))
2727                resolve-location))
2728
2729(defun* resolve-relative-location-component (super x &key directory wilden)
2730  (let* ((r (etypecase x
2731              (pathname x)
2732              (string x)
2733              (cons
2734               (return-from resolve-relative-location-component
2735                 (if (null (cdr x))
2736                     (resolve-relative-location-component
2737                      super (car x) :directory directory :wilden wilden)
2738                     (let* ((car (resolve-relative-location-component
2739                                  super (car x) :directory t :wilden nil))
2740                            (cdr (resolve-relative-location-component
2741                                  (merge-pathnames* car super) (cdr x)
2742                                  :directory directory :wilden wilden)))
2743                       (merge-pathnames* cdr car)))))
2744              ((eql :default-directory)
2745               (relativize-pathname-directory (default-directory)))
2746              ((eql :implementation) (implementation-identifier))
2747              ((eql :implementation-type) (string-downcase (implementation-type)))
2748              #-(and (or win32 windows mswindows mingw32) (not cygwin))
2749              ((eql :uid) (princ-to-string (get-uid)))))
2750         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
2751         (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
2752    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
2753      (error "pathname ~S is not relative to ~S" s super))
2754    (merge-pathnames* s super)))
2755
2756(defun* resolve-absolute-location-component (x &key directory wilden)
2757  (let* ((r
2758          (etypecase x
2759            (pathname x)
2760            (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
2761            (cons
2762             (return-from resolve-absolute-location-component
2763               (if (null (cdr x))
2764                   (resolve-absolute-location-component
2765                    (car x) :directory directory :wilden wilden)
2766                   (let* ((car (resolve-absolute-location-component
2767                                (car x) :directory t :wilden nil))
2768                          (cdr (resolve-relative-location-component
2769                                car (cdr x) :directory directory :wilden wilden)))
2770                     (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
2771            ((eql :root)
2772             ;; special magic! we encode such paths as relative pathnames,
2773             ;; but it means "relative to the root of the source pathname's host and device".
2774             (return-from resolve-absolute-location-component
2775               (let ((p (make-pathname :directory '(:relative))))
2776                 (if wilden (wilden p) p))))
2777            ((eql :home) (user-homedir))
2778            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
2779            ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
2780            ((eql :default-directory) (default-directory))))
2781         (s (if (and wilden (not (pathnamep x)))
2782                (wilden r)
2783                r)))
2784    (unless (absolute-pathname-p s)
2785      (error "Not an absolute pathname ~S" s))
2786    s))
2787
2788(defun* resolve-location (x &key directory wilden)
2789  (if (atom x)
2790      (resolve-absolute-location-component x :directory directory :wilden wilden)
2791      (loop :with path = (resolve-absolute-location-component
2792                          (car x) :directory (and (or directory (cdr x)) t)
2793                          :wilden (and wilden (null (cdr x))))
2794        :for (component . morep) :on (cdr x)
2795        :for dir = (and (or morep directory) t)
2796        :for wild = (and wilden (not morep))
2797        :do (setf path (resolve-relative-location-component
2798                        path component :directory dir :wilden wild))
2799        :finally (return path))))
2800
2801(defun* location-designator-p (x)
2802  (flet ((componentp (c) (typep c '(or string pathname keyword))))
2803    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
2804
2805(defun* location-function-p (x)
2806  (and
2807   (consp x)
2808   (length=n-p x 2)
2809   (or (and (equal (first x) :function)
2810            (typep (second x) 'symbol))
2811       (and (equal (first x) 'lambda)
2812            (cddr x)
2813            (length=n-p (second x) 2)))))
2814
2815(defun* validate-output-translations-directive (directive)
2816  (unless
2817      (or (member directive '(:inherit-configuration
2818                              :ignore-inherited-configuration
2819                              :enable-user-cache :disable-cache nil))
2820          (and (consp directive)
2821               (or (and (length=n-p directive 2)
2822                        (or (and (eq (first directive) :include)
2823                                 (typep (second directive) '(or string pathname null)))
2824                            (and (location-designator-p (first directive))
2825                                 (or (location-designator-p (second directive))
2826                                     (location-function-p (second directive))))))
2827                   (and (length=n-p directive 1)
2828                        (location-designator-p (first directive))))))
2829    (error "Invalid directive ~S~%" directive))
2830  directive)
2831
2832(defun* validate-output-translations-form (form)
2833  (validate-configuration-form
2834   form
2835   :output-translations
2836   'validate-output-translations-directive
2837   "output translations"))
2838
2839(defun* validate-output-translations-file (file)
2840  (validate-configuration-file
2841   file 'validate-output-translations-form "output translations"))
2842
2843(defun* validate-output-translations-directory (directory)
2844  (validate-configuration-directory
2845   directory :output-translations 'validate-output-translations-directive))
2846
2847(defun* parse-output-translations-string (string)
2848  (cond
2849    ((or (null string) (equal string ""))
2850     '(:output-translations :inherit-configuration))
2851    ((not (stringp string))
2852     (error "environment string isn't: ~S" string))
2853    ((eql (char string 0) #\")
2854     (parse-output-translations-string (read-from-string string)))
2855    ((eql (char string 0) #\()
2856     (validate-output-translations-form (read-from-string string)))
2857    (t
2858     (loop
2859      :with inherit = nil
2860      :with directives = ()
2861      :with start = 0
2862      :with end = (length string)
2863      :with source = nil
2864      :for i = (or (position *inter-directory-separator* string :start start) end) :do
2865      (let ((s (subseq string start i)))
2866        (cond
2867          (source
2868           (push (list source (if (equal "" s) nil s)) directives)
2869           (setf source nil))
2870          ((equal "" s)
2871           (when inherit
2872             (error "only one inherited configuration allowed: ~S" string))
2873           (setf inherit t)
2874           (push :inherit-configuration directives))
2875          (t
2876           (setf source s)))
2877        (setf start (1+ i))
2878        (when (> start end)
2879          (when source
2880            (error "Uneven number of components in source to destination mapping ~S" string))
2881          (unless inherit
2882            (push :ignore-inherited-configuration directives))
2883          (return `(:output-translations ,@(nreverse directives)))))))))
2884
2885(defparameter *default-output-translations*
2886  '(environment-output-translations
2887    user-output-translations-pathname
2888    user-output-translations-directory-pathname
2889    system-output-translations-pathname
2890    system-output-translations-directory-pathname))
2891
2892(defun* wrapping-output-translations ()
2893  `(:output-translations
2894    ;; Some implementations have precompiled ASDF systems,
2895    ;; so we must disable translations for implementation paths.
2896    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
2897    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
2898    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
2899    ;; All-import, here is where we want user stuff to be:
2900    :inherit-configuration
2901    ;; These are for convenience, and can be overridden by the user:
2902    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
2903    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
2904    ;; We enable the user cache by default, and here is the place we do:
2905    :enable-user-cache))
2906
2907(defparameter *output-translations-file* #p"asdf-output-translations.conf")
2908(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
2909
2910(defun* user-output-translations-pathname ()
2911  (in-user-configuration-directory *output-translations-file* ))
2912(defun* system-output-translations-pathname ()
2913  (in-system-configuration-directory *output-translations-file*))
2914(defun* user-output-translations-directory-pathname ()
2915  (in-user-configuration-directory *output-translations-directory*))
2916(defun* system-output-translations-directory-pathname ()
2917  (in-system-configuration-directory *output-translations-directory*))
2918(defun* environment-output-translations ()
2919  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
2920
2921(defgeneric* process-output-translations (spec &key inherit collect))
2922(declaim (ftype (function (t &key (:collect (or symbol function))) t)
2923                inherit-output-translations))
2924(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
2925                process-output-translations-directive))
2926
2927(defmethod process-output-translations ((x symbol) &key
2928                                        (inherit *default-output-translations*)
2929                                        collect)
2930  (process-output-translations (funcall x) :inherit inherit :collect collect))
2931(defmethod process-output-translations ((pathname pathname) &key inherit collect)
2932  (cond
2933    ((directory-pathname-p pathname)
2934     (process-output-translations (validate-output-translations-directory pathname)
2935                                  :inherit inherit :collect collect))
2936    ((probe-file pathname)
2937     (process-output-translations (validate-output-translations-file pathname)
2938                                  :inherit inherit :collect collect))
2939    (t
2940     (inherit-output-translations inherit :collect collect))))
2941(defmethod process-output-translations ((string string) &key inherit collect)
2942  (process-output-translations (parse-output-translations-string string)
2943                               :inherit inherit :collect collect))
2944(defmethod process-output-translations ((x null) &key inherit collect)
2945  (declare (ignorable x))
2946  (inherit-output-translations inherit :collect collect))
2947(defmethod process-output-translations ((form cons) &key inherit collect)
2948  (dolist (directive (cdr (validate-output-translations-form form)))
2949    (process-output-translations-directive directive :inherit inherit :collect collect)))
2950
2951(defun* inherit-output-translations (inherit &key collect)
2952  (when inherit
2953    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
2954
2955(defun* process-output-translations-directive (directive &key inherit collect)
2956  (if (atom directive)
2957      (ecase directive
2958        ((:enable-user-cache)
2959         (process-output-translations-directive '(t :user-cache) :collect collect))
2960        ((:disable-cache)
2961         (process-output-translations-directive '(t t) :collect collect))
2962        ((:inherit-configuration)
2963         (inherit-output-translations inherit :collect collect))
2964        ((:ignore-inherited-configuration nil)
2965         nil))
2966      (let ((src (first directive))
2967            (dst (second directive)))
2968        (if (eq src :include)
2969            (when dst
2970              (process-output-translations (pathname dst) :inherit nil :collect collect))
2971            (when src
2972              (let ((trusrc (or (eql src t)
2973                                (let ((loc (resolve-location src :directory t :wilden t)))
2974                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
2975                (cond
2976                  ((location-function-p dst)
2977                   (funcall collect
2978                            (list trusrc
2979                                  (if (symbolp (second dst))
2980                                      (fdefinition (second dst))
2981                                      (eval (second dst))))))
2982                  ((eq dst t)
2983                   (funcall collect (list trusrc t)))
2984                  (t
2985                   (let* ((trudst (make-pathname
2986                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
2987                          (wilddst (make-pathname
2988                                    :name :wild :type :wild :version :wild
2989                                    :defaults trudst)))
2990                     (funcall collect (list wilddst t))
2991                     (funcall collect (list trusrc trudst)))))))))))
2992
2993(defun* compute-output-translations (&optional parameter)
2994  "read the configuration, return it"
2995  (remove-duplicates
2996   (while-collecting (c)
2997     (inherit-output-translations
2998      `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
2999   :test 'equal :from-end t))
3000
3001(defun* initialize-output-translations (&optional parameter)
3002  "read the configuration, initialize the internal configuration variable,
3003return the configuration"
3004  (setf (output-translations) (compute-output-translations parameter)))
3005
3006(defun* disable-output-translations ()
3007  "Initialize output translations in a way that maps every file to itself,
3008effectively disabling the output translation facility."
3009  (initialize-output-translations
3010   '(:output-translations :disable-cache :ignore-inherited-configuration)))
3011
3012;; checks an initial variable to see whether the state is initialized
3013;; or cleared. In the former case, return current configuration; in
3014;; the latter, initialize.  ASDF will call this function at the start
3015;; of (asdf:find-system).
3016(defun* ensure-output-translations ()
3017  (if (output-translations-initialized-p)
3018      (output-translations)
3019      (initialize-output-translations)))
3020
3021(defun* translate-pathname* (path absolute-source destination &optional root source)
3022  (declare (ignore source))
3023  (cond
3024    ((functionp destination)
3025     (funcall destination path absolute-source))
3026    ((eq destination t)
3027     path)
3028    ((not (pathnamep destination))
3029     (error "invalid destination"))
3030    ((not (absolute-pathname-p destination))
3031     (translate-pathname path absolute-source (merge-pathnames* destination root)))
3032    (root
3033     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
3034    (t
3035     (translate-pathname path absolute-source destination))))
3036
3037(defun* apply-output-translations (path)
3038  (etypecase path
3039    (logical-pathname
3040     path)
3041    ((or pathname string)
3042     (ensure-output-translations)
3043     (loop :with p = (truenamize path)
3044       :for (source destination) :in (car *output-translations*)
3045       :for root = (when (or (eq source t)
3046                             (and (pathnamep source)
3047                                  (not (absolute-pathname-p source))))
3048                     (pathname-root p))
3049       :for absolute-source = (cond
3050                                ((eq source t) (wilden root))
3051                                (root (merge-pathnames* source root))
3052                                (t source))
3053       :when (or (eq source t) (pathname-match-p p absolute-source))
3054       :return (translate-pathname* p absolute-source destination root source)
3055       :finally (return p)))))
3056
3057(defmethod output-files :around (operation component)
3058  "Translate output files, unless asked not to"
3059  (declare (ignorable operation component))
3060  (values
3061   (multiple-value-bind (files fixedp) (call-next-method)
3062     (if fixedp
3063         files
3064         (mapcar #'apply-output-translations files)))
3065   t))
3066
3067(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
3068  (or output-file
3069      (apply-output-translations
3070       (apply 'compile-file-pathname
3071              (truenamize (lispize-pathname input-file))
3072              keys))))
3073
3074(defun* tmpize-pathname (x)
3075  (make-pathname
3076   :name (format nil "ASDF-TMP-~A" (pathname-name x))
3077   :defaults x))
3078
3079(defun* delete-file-if-exists (x)
3080  (when (and x (probe-file x))
3081    (delete-file x)))
3082
3083(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
3084  (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
3085         (tmp-file (tmpize-pathname output-file))
3086         (status :error))
3087    (multiple-value-bind (output-truename warnings-p failure-p)
3088        (apply 'compile-file input-file :output-file tmp-file keys)
3089      (cond
3090        (failure-p
3091         (setf status *compile-file-failure-behaviour*))
3092        (warnings-p
3093         (setf status *compile-file-warnings-behaviour*))
3094        (t
3095         (setf status :success)))
3096      (ecase status
3097        ((:success :warn :ignore)
3098         (delete-file-if-exists output-file)
3099         (when output-truename
3100           (rename-file output-truename output-file)
3101           (setf output-truename output-file)))
3102        (:error
3103         (delete-file-if-exists output-truename)
3104         (setf output-truename nil)))
3105      (values output-truename warnings-p failure-p))))
3106
3107#+abcl
3108(defun* translate-jar-pathname (source wildcard)
3109  (declare (ignore wildcard))
3110  (let* ((p (pathname (first (pathname-device source))))
3111         (root (format nil "/___jar___file___root___/~@[~A/~]"
3112                       (and (find :windows *features*)
3113                            (pathname-device p)))))
3114    (apply-output-translations
3115     (merge-pathnames*
3116      (relativize-pathname-directory source)
3117      (merge-pathnames*
3118       (relativize-pathname-directory (ensure-directory-pathname p))
3119       root)))))
3120
3121;;;; -----------------------------------------------------------------
3122;;;; Compatibility mode for ASDF-Binary-Locations
3123
3124(defun* enable-asdf-binary-locations-compatibility
3125    (&key
3126     (centralize-lisp-binaries nil)
3127     (default-toplevel-directory
3128         ;; Use ".cache/common-lisp" instead ???
3129         (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
3130                           (user-homedir)))
3131     (include-per-user-information nil)
3132     (map-all-source-files (or #+(or ecl clisp) t nil))
3133     (source-to-target-mappings nil))
3134  #+(or ecl clisp)
3135  (when (null map-all-source-files)
3136    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
3137  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
3138         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
3139         (mapped-files (make-pathname
3140                        :name :wild :version :wild
3141                        :type (if map-all-source-files :wild fasl-type)))
3142         (destination-directory
3143          (if centralize-lisp-binaries
3144              `(,default-toplevel-directory
3145                ,@(when include-per-user-information
3146                        (cdr (pathname-directory (user-homedir))))
3147                :implementation ,wild-inferiors)
3148              `(:root ,wild-inferiors :implementation))))
3149    (initialize-output-translations
3150     `(:output-translations
3151       ,@source-to-target-mappings
3152       ((:root ,wild-inferiors ,mapped-files)
3153        (,@destination-directory ,mapped-files))
3154       (t t)
3155       :ignore-inherited-configuration))))
3156
3157;;;; -----------------------------------------------------------------
3158;;;; Windows shortcut support.  Based on:
3159;;;;
3160;;;; Jesse Hager: The Windows Shortcut File Format.
3161;;;; http://www.wotsit.org/list.asp?fc=13
3162
3163#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
3164(progn
3165(defparameter *link-initial-dword* 76)
3166(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
3167
3168(defun* read-null-terminated-string (s)
3169  (with-output-to-string (out)
3170    (loop :for code = (read-byte s)
3171      :until (zerop code)
3172      :do (write-char (code-char code) out))))
3173
3174(defun* read-little-endian (s &optional (bytes 4))
3175  (loop
3176    :for i :from 0 :below bytes
3177    :sum (ash (read-byte s) (* 8 i))))
3178
3179(defun* parse-file-location-info (s)
3180  (let ((start (file-position s))
3181        (total-length (read-little-endian s))
3182        (end-of-header (read-little-endian s))
3183        (fli-flags (read-little-endian s))
3184        (local-volume-offset (read-little-endian s))
3185        (local-offset (read-little-endian s))
3186        (network-volume-offset (read-little-endian s))
3187        (remaining-offset (read-little-endian s)))
3188    (declare (ignore total-length end-of-header local-volume-offset))
3189    (unless (zerop fli-flags)
3190      (cond
3191        ((logbitp 0 fli-flags)
3192          (file-position s (+ start local-offset)))
3193        ((logbitp 1 fli-flags)
3194          (file-position s (+ start
3195                              network-volume-offset
3196                              #x14))))
3197      (concatenate 'string
3198        (read-null-terminated-string s)
3199        (progn
3200          (file-position s (+ start remaining-offset))
3201          (read-null-terminated-string s))))))
3202
3203(defun* parse-windows-shortcut (pathname)
3204  (with-open-file (s pathname :element-type '(unsigned-byte 8))
3205    (handler-case
3206        (when (and (= (read-little-endian s) *link-initial-dword*)
3207                   (let ((header (make-array (length *link-guid*))))
3208                     (read-sequence header s)
3209                     (equalp header *link-guid*)))
3210          (let ((flags (read-little-endian s)))
3211            (file-position s 76)        ;skip rest of header
3212            (when (logbitp 0 flags)
3213              ;; skip shell item id list
3214              (let ((length (read-little-endian s 2)))
3215                (file-position s (+ length (file-position s)))))
3216            (cond
3217              ((logbitp 1 flags)
3218                (parse-file-location-info s))
3219              (t
3220                (when (logbitp 2 flags)
3221                  ;; skip description string
3222                  (let ((length (read-little-endian s 2)))
3223                    (file-position s (+ length (file-position s)))))
3224                (when (logbitp 3 flags)
3225                  ;; finally, our pathname
3226                  (let* ((length (read-little-endian s 2))
3227                         (buffer (make-array length)))
3228                    (read-sequence buffer s)
3229                    (map 'string #'code-char buffer)))))))
3230      (end-of-file ()
3231        nil)))))
3232
3233;;;; -----------------------------------------------------------------
3234;;;; Source Registry Configuration, by Francois-Rene Rideau
3235;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
3236
3237;; Using ack 1.2 exclusions
3238(defvar *default-source-registry-exclusions*
3239  '(".bzr" ".cdv"
3240    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
3241    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
3242    "_sgbak" "autom4te.cache" "cover_db" "_build"
3243    "debian")) ;; debian often build stuff under the debian directory... BAD.
3244
3245(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
3246
3247(defvar *source-registry* ()
3248  "Either NIL (for uninitialized), or a list of one element,
3249said element itself being a list of directory pathnames where to look for .asd files")
3250
3251(defun* source-registry ()
3252  (car *source-registry*))
3253
3254(defun* (setf source-registry) (new-value)
3255  (setf *source-registry* (list new-value))
3256  new-value)
3257
3258(defun* source-registry-initialized-p ()
3259  (and *source-registry* t))
3260
3261(defun* clear-source-registry ()
3262  "Undoes any initialization of the source registry.
3263You might want to call that before you dump an image that would be resumed
3264with a different configuration, so the configuration would be re-read then."
3265  (setf *source-registry* '())
3266  (values))
3267
3268(defparameter *wild-asd*
3269  (make-pathname :directory nil :name :wild :type "asd" :version :newest))
3270
3271(defun directory-has-asd-files-p (directory)
3272  (and (ignore-errors
3273         (directory (merge-pathnames* *wild-asd* directory)
3274                    #+sbcl #+sbcl :resolve-symlinks nil
3275                    #+ccl #+ccl :follow-links nil
3276                    #+clisp #+clisp :circle t))
3277       t))
3278
3279(defun subdirectories (directory)
3280  (let* ((directory (ensure-directory-pathname directory))
3281         #-cormanlisp
3282         (wild (merge-pathnames*
3283                #-(or abcl allegro lispworks scl)
3284                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
3285                #+(or abcl allegro lispworks scl) "*.*"
3286                directory))
3287         (dirs
3288          #-cormanlisp
3289          (ignore-errors
3290            (directory wild .
3291              #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
3292                    #+ccl '(:follow-links nil :directories t :files nil)
3293                    #+clisp '(:circle t :if-does-not-exist :ignore)
3294                    #+(or cmu scl) '(:follow-links nil :truenamep nil)
3295                    #+digitool '(:directories t)
3296                    #+sbcl '(:resolve-symlinks nil))))
3297          #+cormanlisp (cl::directory-subdirs directory))
3298         #+(or abcl allegro lispworks scl)
3299         (dirs (remove-if-not #+abcl #'extensions:probe-directory
3300                              #+allegro #'excl:probe-directory
3301                              #+lispworks #'lw:file-directory-p
3302                              #-(or abcl allegro lispworks) #'directory-pathname-p
3303                              dirs)))
3304    dirs))
3305
3306(defun collect-sub*directories (directory collectp recursep collector)
3307  (when (funcall collectp directory)
3308    (funcall collector directory))
3309  (dolist (subdir (subdirectories directory))
3310    (when (funcall recursep subdir)
3311      (collect-sub*directories subdir collectp recursep collector))))
3312
3313(defun collect-sub*directories-with-asd
3314    (directory &key
3315     (exclude *default-source-registry-exclusions*)
3316     collect)
3317  (collect-sub*directories
3318   directory
3319   #'directory-has-asd-files-p
3320   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
3321   collect))
3322
3323(defun* validate-source-registry-directive (directive)
3324  (unless
3325      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
3326          (destructuring-bind (kw &rest rest) directive
3327            (case kw
3328              ((:include :directory :tree)
3329               (and (length=n-p rest 1)
3330                    (location-designator-p (first rest))))
3331              ((:exclude :also-exclude)
3332               (every #'stringp rest))
3333              (null rest))))
3334    (error "Invalid directive ~S~%" directive))
3335  directive)
3336
3337(defun* validate-source-registry-form (form)
3338  (validate-configuration-form
3339   form :source-registry 'validate-source-registry-directive "a source registry"))
3340
3341(defun* validate-source-registry-file (file)
3342  (validate-configuration-file
3343   file 'validate-source-registry-form "a source registry"))
3344
3345(defun* validate-source-registry-directory (directory)
3346  (validate-configuration-directory
3347   directory :source-registry 'validate-source-registry-directive))
3348
3349(defun* parse-source-registry-string (string)
3350  (cond
3351    ((or (null string) (equal string ""))
3352     '(:source-registry :inherit-configuration))
3353    ((not (stringp string))
3354     (error "environment string isn't: ~S" string))
3355    ((find (char string 0) "\"(")
3356     (validate-source-registry-form (read-from-string string)))
3357    (t
3358     (loop
3359      :with inherit = nil
3360      :with directives = ()
3361      :with start = 0
3362      :with end = (length string)
3363      :for pos = (position *inter-directory-separator* string :start start) :do
3364      (let ((s (subseq string start (or pos end))))
3365        (cond
3366         ((equal "" s) ; empty element: inherit
3367          (when inherit
3368            (error "only one inherited configuration allowed: ~S" string))
3369          (setf inherit t)
3370          (push ':inherit-configuration directives))
3371         ((ends-with s "//")
3372          (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
3373         (t
3374          (push `(:directory ,s) directives)))
3375        (cond
3376          (pos
3377           (setf start (1+ pos)))
3378          (t
3379           (unless inherit
3380             (push '(:ignore-inherited-configuration) directives))
3381           (return `(:source-registry ,@(nreverse directives))))))))))
3382
3383(defun* register-asd-directory (directory &key recurse exclude collect)
3384  (if (not recurse)
3385      (funcall collect directory)
3386      (collect-sub*directories-with-asd
3387       directory :exclude exclude :collect collect)))
3388
3389(defparameter *default-source-registries*
3390  '(environment-source-registry
3391    user-source-registry
3392    user-source-registry-directory
3393    system-source-registry
3394    system-source-registry-directory
3395    default-source-registry))
3396
3397(defparameter *source-registry-file* #p"source-registry.conf")
3398(defparameter *source-registry-directory* #p"source-registry.conf.d/")
3399
3400(defun* wrapping-source-registry ()
3401  `(:source-registry
3402    #+sbcl (:tree ,(getenv "SBCL_HOME"))
3403    :inherit-configuration
3404    #+cmu (:tree #p"modules:")))
3405(defun* default-source-registry ()
3406  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
3407    `(:source-registry
3408      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
3409      (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
3410      ,@(let*
3411         #+(or unix cygwin)
3412         ((datahome
3413           (or (getenv "XDG_DATA_HOME")
3414               (try (user-homedir) ".local/share/")))
3415          (datadirs
3416           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
3417          (dirs (cons datahome (split-string datadirs :separator ":"))))
3418         #+(and (or win32 windows mswindows mingw32) (not cygwin))
3419         ((datahome (getenv "APPDATA"))
3420          (datadir
3421           #+lispworks (sys:get-folder-path :local-appdata)
3422           #-lispworks (try (getenv "ALLUSERSPROFILE")
3423                            "Application Data"))
3424          (dirs (list datahome datadir)))
3425         #-(or unix win32 windows mswindows mingw32 cygwin)
3426         ((dirs ()))
3427         (loop :for dir :in dirs
3428           :collect `(:directory ,(try dir "common-lisp/systems/"))
3429           :collect `(:tree ,(try dir "common-lisp/source/"))))
3430      :inherit-configuration)))
3431(defun* user-source-registry ()
3432  (in-user-configuration-directory *source-registry-file*))
3433(defun* system-source-registry ()
3434  (in-system-configuration-directory *source-registry-file*))
3435(defun* user-source-registry-directory ()
3436  (in-user-configuration-directory *source-registry-directory*))
3437(defun* system-source-registry-directory ()
3438  (in-system-configuration-directory *source-registry-directory*))
3439(defun* environment-source-registry ()
3440  (getenv "CL_SOURCE_REGISTRY"))
3441
3442(defgeneric* process-source-registry (spec &key inherit register))
3443(declaim (ftype (function (t &key (:register (or symbol function))) t)
3444                inherit-source-registry))
3445(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
3446                process-source-registry-directive))
3447
3448(defmethod process-source-registry ((x symbol) &key inherit register)
3449  (process-source-registry (funcall x) :inherit inherit :register register))
3450(defmethod process-source-registry ((pathname pathname) &key inherit register)
3451  (cond
3452    ((directory-pathname-p pathname)
3453     (process-source-registry (validate-source-registry-directory pathname)
3454                              :inherit inherit :register register))
3455    ((probe-file pathname)
3456     (process-source-registry (validate-source-registry-file pathname)
3457                              :inherit inherit :register register))
3458    (t
3459     (inherit-source-registry inherit :register register))))
3460(defmethod process-source-registry ((string string) &key inherit register)
3461  (process-source-registry (parse-source-registry-string string)
3462                           :inherit inherit :register register))
3463(defmethod process-source-registry ((x null) &key inherit register)
3464  (declare (ignorable x))
3465  (inherit-source-registry inherit :register register))
3466(defmethod process-source-registry ((form cons) &key inherit register)
3467  (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
3468    (dolist (directive (cdr (validate-source-registry-form form)))
3469      (process-source-registry-directive directive :inherit inherit :register register))))
3470
3471(defun* inherit-source-registry (inherit &key register)
3472  (when inherit
3473    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
3474
3475(defun* process-source-registry-directive (directive &key inherit register)
3476  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
3477    (ecase kw
3478      ((:include)
3479       (destructuring-bind (pathname) rest
3480         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
3481      ((:directory)
3482       (destructuring-bind (pathname) rest
3483         (when pathname
3484           (funcall register (resolve-location pathname :directory t)))))
3485      ((:tree)
3486       (destructuring-bind (pathname) rest
3487         (when pathname
3488           (funcall register (resolve-location pathname :directory t)
3489                    :recurse t :exclude *source-registry-exclusions*))))
3490      ((:exclude)
3491       (setf *source-registry-exclusions* rest))
3492      ((:also-exclude)
3493       (appendf *source-registry-exclusions* rest))
3494      ((:default-registry)
3495       (inherit-source-registry '(default-source-registry) :register register))
3496      ((:inherit-configuration)
3497       (inherit-source-registry inherit :register register))
3498      ((:ignore-inherited-configuration)
3499       nil)))
3500  nil)
3501
3502(defun* flatten-source-registry (&optional parameter)
3503  (remove-duplicates
3504   (while-collecting (collect)
3505     (inherit-source-registry
3506      `(wrapping-source-registry
3507        ,parameter
3508        ,@*default-source-registries*)
3509      :register (lambda (directory &key recurse exclude)
3510                  (collect (list directory :recurse recurse :exclude exclude)))))
3511   :test 'equal :from-end t))
3512
3513;; Will read the configuration and initialize all internal variables,
3514;; and return the new configuration.
3515(defun* compute-source-registry (&optional parameter)
3516  (while-collecting (collect)
3517    (dolist (entry (flatten-source-registry parameter))
3518      (destructuring-bind (directory &key recurse exclude) entry
3519        (register-asd-directory
3520         directory
3521         :recurse recurse :exclude exclude :collect #'collect)))))
3522
3523(defun* initialize-source-registry (&optional parameter)
3524  (setf (source-registry) (compute-source-registry parameter)))
3525
3526;; Checks an initial variable to see whether the state is initialized
3527;; or cleared. In the former case, return current configuration; in
3528;; the latter, initialize.  ASDF will call this function at the start
3529;; of (asdf:find-system) to make sure the source registry is initialized.
3530;; However, it will do so *without* a parameter, at which point it
3531;; will be too late to provide a parameter to this function, though
3532;; you may override the configuration explicitly by calling
3533;; initialize-source-registry directly with your parameter.
3534(defun* ensure-source-registry (&optional parameter)
3535  (if (source-registry-initialized-p)
3536      (source-registry)
3537      (initialize-source-registry parameter)))
3538
3539(defun* sysdef-source-registry-search (system)
3540  (ensure-source-registry)
3541  (loop :with name = (coerce-name system)
3542    :for defaults :in (source-registry)
3543    :for file = (probe-asd name defaults)
3544    :when file :return file))
3545
3546(defun* clear-configuration ()
3547  (clear-source-registry)
3548  (clear-output-translations))
3549
3550;;;; -----------------------------------------------------------------
3551;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
3552;;;;
3553(defun* module-provide-asdf (name)
3554  (handler-bind
3555      ((style-warning #'muffle-warning)
3556       (missing-component (constantly nil))
3557       (error (lambda (e)
3558                (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
3559                        name e))))
3560    (let* ((*verbose-out* (make-broadcast-stream))
3561           (system (find-system (string-downcase name) nil)))
3562      (when system
3563        (load-system system)
3564        t))))
3565
3566#+(or abcl clisp clozure cmu ecl sbcl)
3567(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
3568  (when x
3569    (eval `(pushnew 'module-provide-asdf
3570            #+abcl sys::*module-provider-functions*
3571            #+clisp ,x
3572            #+clozure ccl:*module-provider-functions*
3573            #+cmu ext:*module-provider-functions*
3574            #+ecl si:*module-provider-functions*
3575            #+sbcl sb-ext:*module-provider-functions*))))
3576
3577
3578;;;; -------------------------------------------------------------------------
3579;;;; Cleanups after hot-upgrade.
3580;;;; Things to do in case we're upgrading from a previous version of ASDF.
3581;;;; See https://bugs.launchpad.net/asdf/+bug/485687
3582;;;;
3583;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
3584(eval-when (:compile-toplevel :load-toplevel :execute)
3585  #+ecl ;; Support upgrade from before ECL went to 1.369
3586  (when (fboundp 'compile-op-system-p)
3587    (defmethod compile-op-system-p ((op compile-op))
3588      (getf :system-p (compile-op-flags op)))
3589    (defmethod initialize-instance :after ((op compile-op)
3590                                           &rest initargs
3591                                           &key system-p &allow-other-keys)
3592      (declare (ignorable initargs))
3593      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
3594
3595;;;; -----------------------------------------------------------------
3596;;;; Done!
3597(when *load-verbose*
3598  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
3599
3600#+allegro
3601(eval-when (:compile-toplevel :execute)
3602  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
3603    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
3604
3605(pushnew :asdf *features*)
3606(pushnew :asdf2 *features*)
3607
3608(provide :asdf)
3609
3610;;; Local Variables:
3611;;; mode: lisp
3612;;; End:
Note: See TracBrowser for help on using the repository browser.