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

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

Update to ASDF 2.002

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