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

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

ASDF 2.009 from upstream.

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