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

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

Upgrade to ASDF-2.011.

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