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

Last change on this file since 12986 was 12986, checked in by Mark Evenson, 11 years ago

Upgrade to ASDF-2.010.1.

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