source: branches/0.20.x/abcl/src/org/armedbear/lisp/asdf.lisp

Last change on this file was 12666, checked in by Mark Evenson, 15 years ago

Fix ASDF:MERGE-PATHNAMES* in the case that default directory is nil.

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