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

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

Update to ASDF 2.004.

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