1 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2 ;;; This is ASDF 2.015.3: Another System Definition Facility.
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/>.
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 master
14 ;;; branch is the latest development version, whereas the git release
15 ;;; branch may be slightly older but is considered `stable'
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)
22 ;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
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:
32 ;;; The above copyright notice and this permission notice shall be
33 ;;; included in all copies or substantial portions of the Software.
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.
45 ;;; The problem with writing a defsystem replacement is bootstrapping:
46 ;;; we can't use defsystem to compile it. Hence, all in one file.
50 (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
52 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
53 (error "ASDF is not supported on your implementation. Please help us with it.")
55 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
57 (eval-when (:compile-toplevel :load-toplevel :execute)
58 ;;; Implementation-dependent tweaks
59 ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
61 (setf excl::*autoload-package-name-alist*
62 (remove "asdf" excl::*autoload-package-name-alist*
63 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
64 #+(and ecl (not ecl-bytecmp)) (require :cmp)
65 #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
66 #+(or unix cygwin) (pushnew :asdf-unix *features*)
67 ;;; make package if it doesn't exist yet.
68 ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
69 (unless (find-package :asdf)
70 (make-package :asdf :use '(:common-lisp))))
74 ;;;; Create packages in a way that is compatible with hot-upgrade.
75 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
76 ;;;; See more near the end of the file.
78 (eval-when (:load-toplevel :compile-toplevel :execute)
79 (defvar *asdf-version* nil)
80 (defvar *upgraded-p* nil)
81 (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
82 ;; Strip out formatting that is not supported on Genera.
83 ;; Has to be inside the eval-when to make Lispworks happy (!)
84 (defmacro compatfmt (format)
87 (loop :for (unsupported . replacement) :in
93 (loop :for found = (search unsupported format) :while found :do
95 (concatenate 'simple-string
96 (subseq format 0 found) replacement
97 (subseq format (+ found (length unsupported)))))))
99 (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
100 ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
101 ;; can help you do these changes in synch (look at the source for documentation).
102 ;; Relying on its automation, the version is now redundantly present on top of this file.
103 ;; "2.345" would be an official release
104 ;; "2.345.6" would be a development version in the official upstream
105 ;; "2.345.0.7" would be your seventh local modification of official release 2.345
106 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
107 (asdf-version "2.015.3")
108 (existing-asdf (fboundp 'find-system))
109 (existing-version *asdf-version*)
110 (already-there (equal asdf-version existing-version)))
111 (unless (and existing-asdf already-there)
112 (when (and existing-asdf *asdf-verbose*)
113 (format *trace-output*
114 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
115 existing-version asdf-version))
117 ((present-symbol-p (symbol package)
118 (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
119 (present-symbols (package)
120 ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
122 (do-symbols (s package)
123 (when (present-symbol-p s package) (push s l)))
125 (unlink-package (package)
126 (let ((u (find-package package)))
128 (ensure-unintern u (present-symbols u))
129 (loop :for p :in (package-used-by-list u) :do
131 (delete-package u))))
132 (ensure-exists (name nicknames use)
135 (mapcar #'find-package (cons name nicknames))
137 ;; do away with packages with conflicting (nick)names
138 (map () #'unlink-package (cdr previous))
139 ;; reuse previous package with same name
140 (let ((p (car previous)))
143 (rename-package p name nicknames)
147 (make-package name :nicknames nicknames :use use))))))
148 (find-sym (symbol package)
149 (find-symbol (string symbol) package))
150 (intern* (symbol package)
151 (intern (string symbol) package))
152 (remove-symbol (symbol package)
153 (let ((sym (find-sym symbol package)))
155 #-cormanlisp (unexport sym package)
156 (unintern sym package)
158 (ensure-unintern (package symbols)
159 (loop :with packages = (list-all-packages)
161 :for removed = (remove-symbol sym package)
163 (loop :for p :in packages :do
164 (when (eq removed (find-sym sym p))
165 (unintern removed p)))))
166 (ensure-shadow (package symbols)
167 (shadow symbols package))
168 (ensure-use (package use)
169 (dolist (used (reverse use))
170 (do-external-symbols (sym used)
171 (unless (eq sym (find-sym sym package))
172 (remove-symbol sym package)))
173 (use-package used package)))
174 (ensure-fmakunbound (package symbols)
175 (loop :for name :in symbols
176 :for sym = (find-sym name package)
177 :when sym :do (fmakunbound sym)))
178 (ensure-export (package export)
179 (let ((formerly-exported-symbols nil)
180 (bothly-exported-symbols nil)
181 (newly-exported-symbols nil))
182 (do-external-symbols (sym package)
183 (if (member sym export :test 'string-equal)
184 (push sym bothly-exported-symbols)
185 (push sym formerly-exported-symbols)))
186 (loop :for sym :in export :do
187 (unless (member sym bothly-exported-symbols :test 'string-equal)
188 (push sym newly-exported-symbols)))
189 (loop :for user :in (package-used-by-list package)
190 :for shadowing = (package-shadowing-symbols user) :do
191 (loop :for new :in newly-exported-symbols
192 :for old = (find-sym new user)
193 :when (and old (not (member old shadowing)))
194 :do (unintern old user)))
195 (loop :for x :in newly-exported-symbols :do
196 (export (intern* x package)))))
197 (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
198 (let* ((p (ensure-exists name nicknames use)))
199 (ensure-unintern p unintern)
200 (ensure-shadow p shadow)
201 (ensure-export p export)
202 (ensure-fmakunbound p fmakunbound)
205 ((pkgdcl (name &key nicknames use export
206 redefined-functions unintern fmakunbound shadow)
208 ',name :nicknames ',nicknames :use ',use :export ',export
210 :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
211 :fmakunbound ',(append fmakunbound))))
214 :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
217 (#:perform #:explain #:output-files #:operation-done-p
218 #:perform-with-restarts #:component-relative-pathname
219 #:system-source-file #:operate #:find-component #:find-system
220 #:apply-output-translations #:translate-pathname* #:resolve-location
221 #:compile-file* #:source-file-type)
223 (#:*asdf-revision* #:around #:asdf-method-combination
224 #:split #:make-collector
225 #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
227 (#:system-source-file
228 #:component-relative-pathname #:system-relative-pathname
229 #:process-source-registry
230 #:inherit-source-registry #:process-source-registry-directive)
232 (#:defsystem #:oos #:operate #:find-system #:run-shell-command
233 #:system-definition-pathname #:with-system-definitions
234 #:search-for-system-definition #:find-component ; miscellaneous
235 #:compile-system #:load-system #:test-system #:clear-system
236 #:compile-op #:load-op #:load-source-op
238 #:operation ; operations
239 #:feature ; sort-of operation
240 #:version ; metaphorically sort-of an operation
243 #:implementation-identifier #:implementation-type
245 #:input-files #:output-files #:output-file #:perform ; operation methods
246 #:operation-done-p #:explain
248 #:component #:source-file
249 #:c-source-file #:cl-source-file #:java-source-file
250 #:cl-source-file.cl #:cl-source-file.lsp
256 #:module ; components
260 #:module-components ; component accessors
261 #:module-components-by-name ; component accessors
263 #:component-relative-pathname
270 #:component-depends-on
273 #:system-long-description
279 #:system-source-directory
280 #:system-relative-pathname
283 #:operation-description
284 #:operation-on-warnings
285 #:operation-on-failure
286 #:component-visited-p
287 ;;#:*component-parent-pathname*
288 #:*system-definition-search-functions*
289 #:*central-registry* ; variables
290 #:*compile-file-warnings-behaviour*
291 #:*compile-file-failure-behaviour*
297 #:operation-error #:compile-failed #:compile-warned #:compile-error
300 #:load-system-definition-error
301 #:error-component #:error-operation
302 #:system-definition-error
304 #:missing-component-of-version
306 #:missing-dependency-of-version
307 #:circular-dependency ; errors
313 #:coerce-entry-to-directory
314 #:remove-entry-from-registry
316 #:clear-configuration
317 #:*output-translations-parameter*
318 #:initialize-output-translations
319 #:disable-output-translations
320 #:clear-output-translations
321 #:ensure-output-translations
322 #:apply-output-translations
324 #:compile-file-pathname*
325 #:enable-asdf-binary-locations-compatibility
326 #:*default-source-registries*
327 #:*source-registry-parameter*
328 #:initialize-source-registry
329 #:compute-source-registry
330 #:clear-source-registry
331 #:ensure-source-registry
332 #:process-source-registry
333 #:system-registered-p
337 #:absolute-pathname-p
341 #:directory-pathname-p
343 #:ensure-directory-pathname
350 #:pathname-directory-pathname
356 #:component-name-to-pathname-components
360 #:while-collecting)))
361 #+genera (import 'scl:boolean :asdf)
362 (setf *asdf-version* asdf-version
363 *upgraded-p* (if existing-version
364 (cons existing-version *upgraded-p*)
367 ;;;; -------------------------------------------------------------------------
368 ;;;; User-visible parameters
370 (defun asdf-version ()
371 "Exported interface to the version of ASDF currently installed. A string.
372 You can compare this string with e.g.:
373 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
376 (defvar *resolve-symlinks* t
377 "Determine whether or not ASDF resolves symlinks when defining systems.
381 (defvar *compile-file-warnings-behaviour*
382 (or #+clisp :ignore :warn)
383 "How should ASDF react if it encounters a warning when compiling a file?
384 Valid values are :error, :warn, and :ignore.")
386 (defvar *compile-file-failure-behaviour*
387 (or #+sbcl :error #+clisp :ignore :warn)
388 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
389 when compiling a file? Valid values are :error, :warn, and :ignore.
390 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
392 (defvar *verbose-out* nil)
394 (defparameter +asdf-methods+
395 '(perform-with-restarts perform explain output-files operation-done-p))
398 (eval-when (:compile-toplevel :execute)
399 (defparameter *acl-warn-save*
400 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
401 excl:*warn-on-nested-reader-conditionals*))
402 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
403 (setf excl:*warn-on-nested-reader-conditionals* nil)))
405 ;;;; -------------------------------------------------------------------------
406 ;;;; Resolve forward references
408 (declaim (ftype (function (t) t)
409 format-arguments format-control
410 error-name error-pathname error-condition
412 error-component error-operation
413 module-components module-components-by-name
414 circular-dependency-components
415 condition-arguments condition-form
416 condition-format condition-location
419 (ftype (function (t t) t) (setf module-components-by-name)))
421 ;;;; -------------------------------------------------------------------------
422 ;;;; Compatibility with Corman Lisp
425 (deftype logical-pathname () nil)
426 (defun make-broadcast-stream () *error-output*)
427 (defun file-namestring (p)
428 (setf p (pathname p))
429 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
430 (defparameter *count* 3)
432 (format *error-output* "~S~%" x)))
434 (defun maybe-break ()
436 (unless (plusp *count*)
440 ;;;; -------------------------------------------------------------------------
441 ;;;; General Purpose Utilities
445 `(defmacro ,def* (name formals &rest rest)
447 #+(or ecl gcl) (fmakunbound ',name)
448 #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
449 ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
450 `(declaim (notinline ,name)))
451 (,',def ,name ,formals ,@rest)))))
452 (defdef defgeneric* defgeneric)
453 (defdef defun* defun))
455 (defmacro while-collecting ((&rest collectors) &body body)
456 "COLLECTORS should be a list of names for collections. A collector
457 defines a function that, when applied to an argument inside BODY, will
458 add its argument to the corresponding collection. Returns multiple values,
459 a list for each collection, in order.
461 \(while-collecting \(foo bar\)
462 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
464 \(bar \(second x\)\)\)\)
465 Returns two values: \(A B C\) and \(1 2 3\)."
466 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
467 (initial-values (mapcar (constantly nil) collectors)))
468 `(let ,(mapcar #'list vars initial-values)
469 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
471 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
473 (defmacro aif (test then &optional else)
474 `(let ((it ,test)) (if it ,then ,else)))
476 (defun* pathname-directory-pathname (pathname)
477 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
478 and NIL NAME, TYPE and VERSION components"
480 (make-pathname :name nil :type nil :version nil :defaults pathname)))
482 (defun* normalize-pathname-directory-component (directory)
485 ((stringp directory) `(:absolute ,directory) directory)
487 ((and (consp directory) (stringp (first directory)))
488 `(:absolute ,@directory))
489 ((or (null directory)
490 (and (consp directory) (member (first directory) '(:absolute :relative))))
493 (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
495 (defun* merge-pathname-directory-components (specified defaults)
496 (let ((directory (normalize-pathname-directory-component specified)))
497 (ecase (first directory)
499 (:absolute specified)
501 (let ((defdir (normalize-pathname-directory-component defaults))
502 (reldir (cdr directory)))
506 ((not (eq :back (first reldir)))
507 (append defdir reldir))
509 (loop :with defabs = (first defdir)
510 :with defrev = (reverse (rest defdir))
511 :while (and (eq :back (car reldir))
512 (or (and (eq :absolute defabs) (null defrev))
513 (stringp (car defrev))))
514 :do (pop reldir) (pop defrev)
515 :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
517 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
518 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
519 does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
520 Also, if either argument is NIL, then the other argument is returned unmodified."
521 (when (null specified) (return-from merge-pathnames* defaults))
522 (when (null defaults) (return-from merge-pathnames* specified))
524 (ext:resolve-pathname specified defaults)
526 (let* ((specified (pathname specified))
527 (defaults (pathname defaults))
528 (directory (normalize-pathname-directory-component (pathname-directory specified)))
529 (name (or (pathname-name specified) (pathname-name defaults)))
530 (type (or (pathname-type specified) (pathname-type defaults)))
531 (version (or (pathname-version specified) (pathname-version defaults))))
532 (labels ((ununspecific (x)
533 (if (eq x :unspecific) nil x))
534 (unspecific-handler (p)
535 (if (typep p 'logical-pathname) #'ununspecific #'identity)))
536 (multiple-value-bind (host device directory unspecific-handler)
537 (ecase (first directory)
539 (values (pathname-host specified)
540 (pathname-device specified)
542 (unspecific-handler specified)))
544 (values (pathname-host defaults)
545 (pathname-device defaults)
546 (merge-pathname-directory-components directory (pathname-directory defaults))
547 (unspecific-handler defaults))))
548 (make-pathname :host host :device device :directory directory
549 :name (funcall unspecific-handler name)
550 :type (funcall unspecific-handler type)
551 :version (funcall unspecific-handler version))))))
553 (defun* pathname-parent-directory-pathname (pathname)
554 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
555 and NIL NAME, TYPE and VERSION components"
557 (make-pathname :name nil :type nil :version nil
558 :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
559 :defaults pathname)))
562 (define-modify-macro appendf (&rest args)
563 append "Append onto list") ;; only to be used on short lists.
565 (define-modify-macro orf (&rest args)
568 (defun* first-char (s)
569 (and (stringp s) (plusp (length s)) (char s 0)))
571 (defun* last-char (s)
572 (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
575 (defun* asdf-message (format-string &rest format-args)
576 (declare (dynamic-extent format-args))
577 (apply 'format *verbose-out* format-string format-args))
579 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
580 "Split STRING into a list of components separated by
581 any of the characters in the sequence SEPARATOR.
582 If MAX is specified, then no more than max(1,MAX) components will be returned,
583 starting the separation from the end, e.g. when called with arguments
584 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
586 (let ((list nil) (words 0) (end (length string)))
587 (flet ((separatorp (char) (find char separator))
588 (done () (throw nil (cons (subseq string 0 end) list))))
590 :for start = (if (and max (>= words (1- max)))
592 (position-if #'separatorp string :end end :from-end t)) :do
595 (push (subseq string (1+ start) end) list)
597 (setf end start))))))
599 (defun* split-name-type (filename)
601 ;; Giving :unspecific as argument to make-pathname is not portable.
602 ;; See CLHS make-pathname and 19.2.2.2.3.
603 ;; We only use it on implementations that support it.
604 (or #+(or clozure gcl lispworks sbcl) :unspecific)))
605 (destructuring-bind (name &optional (type unspecific))
606 (split-string filename :max 2 :separator ".")
608 (values filename unspecific)
609 (values name type)))))
611 (defun* component-name-to-pathname-components (s &key force-directory force-relative)
612 "Splits the path string S, returning three values:
613 A flag that is either :absolute or :relative, indicating
614 how the rest of the values are to be interpreted.
615 A directory path --- a list of strings, suitable for
616 use with MAKE-PATHNAME when prepended with the flag
618 A filename with type extension, possibly NIL in the
619 case of a directory pathname.
620 FORCE-DIRECTORY forces S to be interpreted as a directory
621 pathname \(third return value will be NIL, final component
622 of S will be treated as part of the directory path.
624 The intention of this function is to support structured component names,
625 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
627 (check-type s string)
629 (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
630 (let* ((components (split-string s :separator "/"))
631 (last-comp (car (last components))))
632 (multiple-value-bind (relative components)
633 (if (equal (first components) "")
634 (if (equal (first-char s) #\/)
637 (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
638 (values :absolute (cdr components)))
639 (values :relative nil))
640 (values :relative components))
641 (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
642 (setf components (substitute :back ".." components :test #'equal))
644 ((equal last-comp "")
645 (values relative components nil)) ; "" already removed
647 (values relative components nil))
649 (values relative (butlast components) last-comp))))))
651 (defun* remove-keys (key-names args)
652 (loop :for (name val) :on args :by #'cddr
653 :unless (member (symbol-name name) key-names
654 :key #'symbol-name :test 'equal)
655 :append (list name val)))
657 (defun* remove-keyword (key args)
658 (loop :for (k v) :on args :by #'cddr
663 (eval-when (:compile-toplevel :load-toplevel :execute)
664 (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
667 (declare (ignorable x))
668 #+(or abcl clisp xcl) (ext:getenv x)
669 #+allegro (sys:getenv x)
670 #+clozure (ccl:getenv x)
671 #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
673 (let* ((buffer (ct:malloc 1))
674 (cname (ct:lisp-string-to-c-string x))
675 (needed-size (win:getenvironmentvariable cname buffer 0))
676 (buffer1 (ct:malloc (1+ needed-size))))
677 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
679 (ct:c-string-to-lisp-string buffer1))
683 #+gcl (system:getenv x)
685 #+lispworks (lispworks:environment-variable x)
686 #+mcl (ccl:with-cstrs ((name x))
687 (let ((value (_getenv name)))
688 (unless (ccl:%null-ptr-p value)
689 (ccl:%get-cstring value))))
690 #+sbcl (sb-ext:posix-getenv x)
691 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
692 (error "~S is not supported on your implementation" 'getenv))
694 (defun* directory-pathname-p (pathname)
695 "Does PATHNAME represent a directory?
697 A directory-pathname is a pathname _without_ a filename. The three
698 ways that the filename components can be missing are for it to be NIL,
699 :UNSPECIFIC or the empty string.
701 Note that this does _not_ check to see that PATHNAME points to an
702 actually-existing directory."
704 (let ((pathname (pathname pathname)))
705 (flet ((check-one (x)
706 (member x '(nil :unspecific "") :test 'equal)))
707 (and (not (wild-pathname-p pathname))
708 (check-one (pathname-name pathname))
709 (check-one (pathname-type pathname))
712 (defun* ensure-directory-pathname (pathspec)
713 "Converts the non-wild pathname designator PATHSPEC to directory form."
716 (ensure-directory-pathname (pathname pathspec)))
717 ((not (pathnamep pathspec))
718 (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
719 ((wild-pathname-p pathspec)
720 (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
721 ((directory-pathname-p pathspec)
724 (make-pathname :directory (append (or (pathname-directory pathspec)
726 (list (file-namestring pathspec)))
727 :name nil :type nil :version nil
728 :defaults pathspec))))
731 (unless (fboundp 'ensure-directories-exist)
732 (defun ensure-directories-exist (path)
733 (fs:create-directories-recursively (pathname path))))
735 (defun* absolute-pathname-p (pathspec)
736 (and (typep pathspec '(or pathname string))
737 (eq :absolute (car (pathname-directory (pathname pathspec))))))
739 (defun* length=n-p (x n) ;is it that (= (length x) n) ?
740 (check-type n (integer 0 *))
742 :for l = x :then (cdr l)
743 :for i :downfrom n :do
745 ((zerop i) (return (null l)))
746 ((not (consp l)) (return nil)))))
748 (defun* ends-with (s suffix)
749 (check-type s string)
750 (check-type suffix string)
751 (let ((start (- (length s) (length suffix))))
753 (string-equal s suffix :start1 start))))
755 (defun* read-file-forms (file)
756 (with-open-file (in file)
757 (loop :with eof = (list nil)
758 :for form = (read in nil eof)
764 #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
765 '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
767 #+allegro (excl.osi:getuid)
769 #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
770 :for f = (ignore-errors (read-from-string s))
771 :when f :return (funcall f))
772 #+(or cmu scl) (unix:unix-getuid)
773 #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
774 '(ffi:c-inline () () :int "getuid()" :one-liner t)
776 #+sbcl (sb-unix:unix-getuid)
777 #-(or allegro ccl clisp cmu ecl sbcl scl)
779 (with-output-to-string (*verbose-out*)
780 (run-shell-command "id -ur"))))
781 (with-input-from-string (stream uid-string)
783 (handler-case (parse-integer (read-line stream))
784 (error () (error "Unable to find out user ID")))))))
786 (defun* pathname-root (pathname)
787 (make-pathname :directory '(:absolute)
788 :name nil :type nil :version nil
789 :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
790 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
792 (defun* find-symbol* (s p)
793 (find-symbol (string s) p))
795 (defun* probe-file* (p)
796 "when given a pathname P, probes the filesystem for a file or directory
797 with given pathname and if it exists return its truename."
800 (string (probe-file* (parse-namestring p)))
801 (pathname (unless (wild-pathname-p p)
802 #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
803 #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
804 '(ignore-errors (truename p)))))))
806 (defun* truenamize (p)
807 "Resolve as much of a pathname as possible"
809 (when (typep p '(or null logical-pathname)) (return p))
810 (let* ((p (merge-pathnames* p))
811 (directory (pathname-directory p)))
812 (when (typep p 'logical-pathname) (return p))
813 (let ((found (probe-file* p)))
814 (when found (return found)))
815 #-(or cmu sbcl scl) (when (stringp directory) (return p))
816 (when (not (eq :absolute (car directory))) (return p))
817 (let ((sofar (probe-file* (pathname-root p))))
818 (unless sofar (return p))
819 (flet ((solution (directories)
821 (make-pathname :host nil :device nil
822 :directory `(:relative ,@directories)
823 :name (pathname-name p)
824 :type (pathname-type p)
825 :version (pathname-version p))
827 (loop :for component :in (cdr directory)
828 :for rest :on (cdr directory)
829 :for more = (probe-file*
831 (make-pathname :directory `(:relative ,component))
835 (return (solution rest)))
837 (return (solution nil))))))))
839 (defun* resolve-symlinks (path)
840 #-allegro (truenamize path)
841 #+allegro (if (typep path 'logical-pathname)
843 (excl:pathname-resolve-symbolic-links path)))
845 (defun* resolve-symlinks* (path)
846 (if *resolve-symlinks*
847 (and path (resolve-symlinks path))
850 (defun ensure-pathname-absolute (path)
852 ((absolute-pathname-p path) path)
853 ((stringp path) (ensure-pathname-absolute (pathname path)))
854 ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
855 (t (let ((resolved (resolve-symlinks path)))
856 (assert (absolute-pathname-p resolved))
859 (defun* default-directory ()
860 (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
862 (defun* lispize-pathname (input-file)
863 (make-pathname :type "lisp" :defaults input-file))
865 (defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
866 (defparameter *wild-file*
867 (make-pathname :name *wild* :type *wild* :version *wild* :directory nil))
868 (defparameter *wild-directory*
869 (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
870 (defparameter *wild-inferiors*
871 (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
872 (defparameter *wild-path*
873 (merge-pathnames *wild-file* *wild-inferiors*))
875 (defun* wilden (path)
876 (merge-pathnames* *wild-path* path))
879 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
880 (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
881 (last-char (namestring foo))))
884 (defun* directorize-pathname-host-device (pathname)
885 (let* ((root (pathname-root pathname))
886 (wild-root (wilden root))
887 (absolute-pathname (merge-pathnames* pathname root))
888 (separator (directory-separator-for-host root))
889 (root-namestring (namestring root))
892 #'(lambda (x) (or (eql x #\:)
895 (multiple-value-bind (relative path filename)
896 (component-name-to-pathname-components root-string :force-directory t)
897 (declare (ignore relative filename))
899 (make-pathname :defaults root
900 :directory `(:absolute ,@path))))
901 (translate-pathname absolute-pathname wild-root (wilden new-base))))))
904 (defun* directorize-pathname-host-device (pathname)
905 (let ((scheme (ext:pathname-scheme pathname))
906 (host (pathname-host pathname))
907 (port (ext:pathname-port pathname))
908 (directory (pathname-directory pathname)))
909 (flet ((not-unspecific (component)
910 (and (not (eq component :unspecific)) component)))
911 (cond ((or (not-unspecific port)
912 (and (not-unspecific host) (plusp (length host)))
913 (not-unspecific scheme))
915 (when (not-unspecific port)
916 (setf prefix (format nil ":~D" port)))
917 (when (and (not-unspecific host) (plusp (length host)))
918 (setf prefix (concatenate 'string host prefix)))
919 (setf prefix (concatenate 'string ":" prefix))
920 (when (not-unspecific scheme)
921 (setf prefix (concatenate 'string scheme prefix)))
922 (assert (and directory (eq (first directory) :absolute)))
923 (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
924 :defaults pathname)))
928 ;;;; -------------------------------------------------------------------------
929 ;;;; ASDF Interface, in terms of generic functions.
930 (defgeneric* find-system (system &optional error-p))
931 (defgeneric* perform-with-restarts (operation component))
932 (defgeneric* perform (operation component))
933 (defgeneric* operation-done-p (operation component))
934 (defgeneric* explain (operation component))
935 (defgeneric* output-files (operation component))
936 (defgeneric* input-files (operation component))
937 (defgeneric* component-operation-time (operation component))
938 (defgeneric* operation-description (operation component)
939 (:documentation "returns a phrase that describes performing this operation
940 on this component, e.g. \"loading /a/b/c\".
941 You can put together sentences using this phrase."))
943 (defgeneric* system-source-file (system)
944 (:documentation "Return the source file in which system is defined."))
946 (defgeneric* component-system (component)
947 (:documentation "Find the top-level system containing COMPONENT"))
949 (defgeneric* component-pathname (component)
950 (:documentation "Extracts the pathname applicable for a particular component."))
952 (defgeneric* component-relative-pathname (component)
953 (:documentation "Returns a pathname for the component argument intended to be
954 interpreted relative to the pathname of that component's parent.
955 Despite the function's name, the return value may be an absolute
956 pathname, because an absolute pathname may be interpreted relative to
957 another pathname in a degenerate way."))
959 (defgeneric* component-property (component property))
961 (defgeneric* (setf component-property) (new-value component property))
963 (eval-when (:compile-toplevel :load-toplevel :execute)
964 (defgeneric* (setf module-components-by-name) (new-value module)))
966 (defgeneric* version-satisfies (component version))
968 (defgeneric* find-component (base path)
969 (:documentation "Finds the component with PATH starting from BASE module;
970 if BASE is nil, then the component is assumed to be a system."))
972 (defgeneric* source-file-type (component system))
974 (defgeneric* operation-ancestor (operation)
976 "Recursively chase the operation's parent pointer until we get to
977 the head of the tree"))
979 (defgeneric* component-visited-p (operation component)
980 (:documentation "Returns the value stored by a call to
981 VISIT-COMPONENT, if that has been called, otherwise NIL.
982 This value stored will be a cons cell, the first element
983 of which is a computed key, so not interesting. The
984 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
985 it as (cdr (component-visited-p op c)).
986 In the current form of ASDF, the DATA value retrieved is
987 effectively a boolean, indicating whether some operations are
988 to be performed in order to do OPERATION X COMPONENT. If the
989 data value is NIL, the combination had been explored, but no
990 operations needed to be performed."))
992 (defgeneric* visit-component (operation component data)
993 (:documentation "Record DATA as being associated with OPERATION
994 and COMPONENT. This is a side-effecting function: the association
995 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
997 No evidence that DATA is ever interesting, beyond just being
998 non-NIL. Using the data field is probably very risky; if there is
999 already a record for OPERATION X COMPONENT, DATA will be quietly
1000 discarded instead of recorded.
1001 Starting with 2.006, TRAVERSE will store an integer in data,
1002 so that nodes can be sorted in decreasing order of traversal."))
1005 (defgeneric* (setf visiting-component) (new-value operation component))
1007 (defgeneric* component-visiting-p (operation component))
1009 (defgeneric* component-depends-on (operation component)
1011 "Returns a list of dependencies needed by the component to perform
1012 the operation. A dependency has one of the following forms:
1014 (<operation> <component>*), where <operation> is a class
1015 designator and each <component> is a component
1016 designator, which means that the component depends on
1017 <operation> having been performed on each <component>; or
1019 (FEATURE <feature>), which means that the component depends
1020 on <feature>'s presence in *FEATURES*.
1022 Methods specialized on subclasses of existing component types
1023 should usually append the results of CALL-NEXT-METHOD to the
1026 (defgeneric* component-self-dependencies (operation component))
1028 (defgeneric* traverse (operation component)
1030 "Generate and return a plan for performing OPERATION on COMPONENT.
1032 The plan returned is a list of dotted-pairs. Each pair is the CONS
1033 of ASDF operation object and a COMPONENT object. The pairs will be
1034 processed in order by OPERATE."))
1037 ;;;; -------------------------------------------------------------------------
1038 ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
1040 (when (find-class 'module nil)
1042 '(defmethod update-instance-for-redefined-class :after
1043 ((m module) added deleted plist &key)
1044 (declare (ignorable deleted plist))
1045 (when *asdf-verbose*
1046 (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
1048 (when (member 'components-by-name added)
1049 (compute-module-components-by-name m))
1050 (when (typep m 'system)
1051 (when (member 'source-file added)
1052 (%set-system-source-file
1053 (probe-asd (component-name m) (component-pathname m)) m)
1054 (when (equal (component-name m) "asdf")
1055 (setf (component-version m) *asdf-version*))))))))
1057 ;;;; -------------------------------------------------------------------------
1058 ;;;; Classes, Conditions
1060 (define-condition system-definition-error (error) ()
1061 ;; [this use of :report should be redundant, but unfortunately it's not.
1062 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
1063 ;; over print-object; this is always conditions::%print-condition for
1064 ;; condition objects, which in turn does inheritance of :report options at
1065 ;; run-time. fortunately, inheritance means we only need this kludge here in
1066 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
1067 #+cmu (:report print-object))
1069 (define-condition formatted-system-definition-error (system-definition-error)
1070 ((format-control :initarg :format-control :reader format-control)
1071 (format-arguments :initarg :format-arguments :reader format-arguments))
1072 (:report (lambda (c s)
1073 (apply 'format s (format-control c) (format-arguments c)))))
1075 (define-condition load-system-definition-error (system-definition-error)
1076 ((name :initarg :name :reader error-name)
1077 (pathname :initarg :pathname :reader error-pathname)
1078 (condition :initarg :condition :reader error-condition))
1079 (:report (lambda (c s)
1080 (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
1081 (error-name c) (error-pathname c) (error-condition c)))))
1083 (define-condition circular-dependency (system-definition-error)
1084 ((components :initarg :components :reader circular-dependency-components))
1085 (:report (lambda (c s)
1086 (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
1087 (circular-dependency-components c)))))
1089 (define-condition duplicate-names (system-definition-error)
1090 ((name :initarg :name :reader duplicate-names-name))
1091 (:report (lambda (c s)
1092 (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
1093 (duplicate-names-name c)))))
1095 (define-condition missing-component (system-definition-error)
1096 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
1097 (parent :initform nil :reader missing-parent :initarg :parent)))
1099 (define-condition missing-component-of-version (missing-component)
1100 ((version :initform nil :reader missing-version :initarg :version)))
1102 (define-condition missing-dependency (missing-component)
1103 ((required-by :initarg :required-by :reader missing-required-by)))
1105 (define-condition missing-dependency-of-version (missing-dependency
1106 missing-component-of-version)
1109 (define-condition operation-error (error)
1110 ((component :reader error-component :initarg :component)
1111 (operation :reader error-operation :initarg :operation))
1112 (:report (lambda (c s)
1113 (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
1114 (error-operation c) (error-component c)))))
1115 (define-condition compile-error (operation-error) ())
1116 (define-condition compile-failed (compile-error) ())
1117 (define-condition compile-warned (compile-error) ())
1119 (define-condition invalid-configuration ()
1120 ((form :reader condition-form :initarg :form)
1121 (location :reader condition-location :initarg :location)
1122 (format :reader condition-format :initarg :format)
1123 (arguments :reader condition-arguments :initarg :arguments :initform nil))
1124 (:report (lambda (c s)
1125 (format s (compatfmt "~@<~? (will be skipped)~@:>")
1126 (condition-format c)
1127 (list* (condition-form c) (condition-location c)
1128 (condition-arguments c))))))
1129 (define-condition invalid-source-registry (invalid-configuration warning)
1130 ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
1131 (define-condition invalid-output-translation (invalid-configuration warning)
1132 ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
1134 (defclass component ()
1135 ((name :accessor component-name :initarg :name :type string :documentation
1136 "Component name: designator for a string composed of portable pathname characters")
1137 (version :accessor component-version :initarg :version) ;; :type (and string (satisfies parse-version)) -- not until we fix all systems that don't use it correctly!
1138 (description :accessor component-description :initarg :description)
1139 (long-description :accessor component-long-description :initarg :long-description)
1140 ;; This one below is used by POIU - http://www.cliki.net/poiu
1141 ;; a parallelizing extension of ASDF that compiles in multiple parallel
1142 ;; slave processes (forked on demand) and loads in the master process.
1143 ;; Maybe in the future ASDF may use it internally instead of in-order-to.
1144 (load-dependencies :accessor component-load-dependencies :initform nil)
1145 ;; In the ASDF object model, dependencies exist between *actions*
1146 ;; (an action is a pair of operation and component). They are represented
1147 ;; alists of operations to dependencies (other actions) in each component.
1148 ;; There are two kinds of dependencies, each stored in its own slot:
1149 ;; in-order-to and do-first dependencies. These two kinds are related to
1150 ;; the fact that some actions modify the filesystem,
1151 ;; whereas other actions modify the current image, and
1152 ;; this implies a difference in how to interpret timestamps.
1153 ;; in-order-to dependencies will trigger re-performing the action
1154 ;; when the timestamp of some dependency
1155 ;; makes the timestamp of current action out-of-date;
1156 ;; do-first dependencies do not trigger such re-performing.
1157 ;; Therefore, a FASL must be recompiled if it is obsoleted
1158 ;; by any of its FASL dependencies (in-order-to); but
1159 ;; it needn't be recompiled just because one of these dependencies
1160 ;; hasn't yet been loaded in the current image (do-first).
1161 ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
1162 ;; See our ASDF 2 paper for more complete explanations.
1163 (in-order-to :initform nil :initarg :in-order-to
1164 :accessor component-in-order-to)
1165 (do-first :initform nil :initarg :do-first
1166 :accessor component-do-first)
1167 ;; methods defined using the "inline" style inside a defsystem form:
1168 ;; need to store them somewhere so we can delete them when the system
1170 (inline-methods :accessor component-inline-methods :initform nil)
1171 (parent :initarg :parent :initform nil :reader component-parent)
1172 ;; no direct accessor for pathname, we do this as a method to allow
1173 ;; it to default in funky ways if not supplied
1174 (relative-pathname :initarg :pathname)
1176 (operation-times :initform (make-hash-table)
1177 :accessor component-operation-times)
1178 ;; XXX we should provide some atomic interface for updating the
1179 ;; component properties
1180 (properties :accessor component-properties :initarg :properties
1183 (defun* component-find-path (component)
1185 (loop :for c = component :then (component-parent c)
1186 :while c :collect (component-name c))))
1188 (defmethod print-object ((c component) stream)
1189 (print-unreadable-object (c stream :type t :identity nil)
1190 (format stream "~{~S~^ ~}" (component-find-path c))))
1193 ;;;; methods: conditions
1195 (defmethod print-object ((c missing-dependency) s)
1196 (format s (compatfmt "~@<~A, required by ~A~@:>")
1197 (call-next-method c nil) (missing-required-by c)))
1199 (defun* sysdef-error (format &rest arguments)
1200 (error 'formatted-system-definition-error :format-control
1201 format :format-arguments arguments))
1203 ;;;; methods: components
1205 (defmethod print-object ((c missing-component) s)
1206 (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
1207 (missing-requires c)
1208 (when (missing-parent c)
1209 (coerce-name (missing-parent c)))))
1211 (defmethod print-object ((c missing-component-of-version) s)
1212 (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
1213 (missing-requires c)
1215 (when (missing-parent c)
1216 (coerce-name (missing-parent c)))))
1218 (defmethod component-system ((component component))
1219 (aif (component-parent component)
1220 (component-system it)
1223 (defvar *default-component-class* 'cl-source-file)
1225 (defun* compute-module-components-by-name (module)
1226 (let ((hash (make-hash-table :test 'equal)))
1227 (setf (module-components-by-name module) hash)
1228 (loop :for c :in (module-components module)
1229 :for name = (component-name c)
1230 :for previous = (gethash name (module-components-by-name module))
1233 (error 'duplicate-names :name name))
1234 :do (setf (gethash name (module-components-by-name module)) c))
1237 (defclass module (component)
1240 :initarg :components
1241 :accessor module-components)
1243 :accessor module-components-by-name)
1244 ;; What to do if we can't satisfy a dependency of one of this module's
1245 ;; components. This allows a limited form of conditional processing.
1246 (if-component-dep-fails
1248 :initarg :if-component-dep-fails
1249 :accessor module-if-component-dep-fails)
1250 (default-component-class
1251 :initform *default-component-class*
1252 :initarg :default-component-class
1253 :accessor module-default-component-class)))
1255 (defun* component-parent-pathname (component)
1256 ;; No default anymore (in particular, no *default-pathname-defaults*).
1257 ;; If you force component to have a NULL pathname, you better arrange
1258 ;; for any of its children to explicitly provide a proper absolute pathname
1259 ;; wherever a pathname is actually wanted.
1260 (let ((parent (component-parent component)))
1262 (component-pathname parent))))
1264 (defmethod component-pathname ((component component))
1265 (if (slot-boundp component 'absolute-pathname)
1266 (slot-value component 'absolute-pathname)
1269 (component-relative-pathname component)
1270 (pathname-directory-pathname (component-parent-pathname component)))))
1271 (unless (or (null pathname) (absolute-pathname-p pathname))
1272 (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
1273 pathname (component-find-path component)))
1274 (setf (slot-value component 'absolute-pathname) pathname)
1277 (defmethod component-property ((c component) property)
1278 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
1280 (defmethod (setf component-property) (new-value (c component) property)
1281 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
1283 (setf (cdr a) new-value)
1284 (setf (slot-value c 'properties)
1285 (acons property new-value (slot-value c 'properties)))))
1288 (defclass system (module)
1289 (;; description and long-description are now available for all component's,
1290 ;; but now also inherited from component, but we add the legacy accessor
1291 (description :accessor system-description :initarg :description)
1292 (long-description :accessor system-long-description :initarg :long-description)
1293 (author :accessor system-author :initarg :author)
1294 (maintainer :accessor system-maintainer :initarg :maintainer)
1295 (licence :accessor system-licence :initarg :licence
1296 :accessor system-license :initarg :license)
1297 (source-file :reader system-source-file :initarg :source-file
1298 :writer %set-system-source-file)
1299 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
1301 ;;;; -------------------------------------------------------------------------
1302 ;;;; version-satisfies
1304 (defmethod version-satisfies ((c component) version)
1305 (unless (and version (slot-boundp c 'version))
1307 (warn "Requested version ~S but component ~S has no version" version c))
1308 (return-from version-satisfies t))
1309 (version-satisfies (component-version c) version))
1311 (defun parse-version (string &optional on-error)
1312 "Parse a version string as a series of natural integers separated by dots.
1313 Return a (non-null) list of integers if the string is valid, NIL otherwise.
1314 If on-error is error, warn, or designates a function of compatible signature,
1315 the function is called with an explanation of what is wrong with the argument.
1316 NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
1318 (or (stringp string)
1320 (funcall on-error "~S: ~S is not a string"
1321 'parse-version string)) nil)
1322 (or (loop :for prev = nil :then c :for c :across string
1323 :always (or (digit-char-p c)
1324 (and (eql c #\.) prev (not (eql prev #\.))))
1325 :finally (return (and c (digit-char-p c))))
1327 (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
1328 'parse-version string)) nil)
1329 (mapcar #'parse-integer (split-string string :separator "."))))
1331 (defmethod version-satisfies ((cver string) version)
1332 (let ((x (parse-version cver 'warn))
1333 (y (parse-version version 'warn)))
1334 (labels ((bigger (x y)
1337 ((> (car x) (car y)) t)
1338 ((= (car x) (car y))
1339 (bigger (cdr x) (cdr y))))))
1340 (and x y (= (car x) (car y))
1341 (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
1343 ;;;; -------------------------------------------------------------------------
1344 ;;;; Finding systems
1346 (defun* make-defined-systems-table ()
1347 (make-hash-table :test 'equal))
1349 (defvar *defined-systems* (make-defined-systems-table)
1350 "This is a hash table whose keys are strings, being the
1351 names of the systems, and whose values are pairs, the first
1352 element of which is a universal-time indicating when the
1353 system definition was last updated, and the second element
1354 of which is a system object.")
1356 (defun* coerce-name (name)
1358 (component (component-name name))
1359 (symbol (string-downcase (symbol-name name)))
1361 (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
1363 (defun* system-registered-p (name)
1364 (gethash (coerce-name name) *defined-systems*))
1366 (defun* register-system (system)
1367 (check-type system system)
1368 (let ((name (component-name system)))
1369 (check-type name string)
1370 (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
1371 (unless (eq system (cdr (gethash name *defined-systems*)))
1372 (setf (gethash name *defined-systems*)
1373 (cons (get-universal-time) system)))))
1375 (defun* clear-system (name)
1376 "Clear the entry for a system in the database of systems previously loaded.
1377 Note that this does NOT in any way cause the code of the system to be unloaded."
1378 ;; There is no "unload" operation in Common Lisp, and
1379 ;; a general such operation cannot be portably written,
1380 ;; considering how much CL relies on side-effects to global data structures.
1381 (remhash (coerce-name name) *defined-systems*))
1383 (defun* map-systems (fn)
1384 "Apply FN to each defined system.
1386 FN should be a function of one argument. It will be
1387 called with an object of type asdf:system."
1388 (maphash #'(lambda (_ datum)
1389 (declare (ignore _))
1390 (destructuring-bind (_ . def) datum
1391 (declare (ignore _))
1395 ;;; for the sake of keeping things reasonably neat, we adopt a
1396 ;;; convention that functions in this list are prefixed SYSDEF-
1398 (defparameter *system-definition-search-functions*
1399 '(sysdef-central-registry-search
1400 sysdef-source-registry-search
1403 (defun* search-for-system-definition (system)
1404 (let ((system-name (coerce-name system)))
1405 (some #'(lambda (x) (funcall x system-name))
1406 (cons 'find-system-if-being-defined *system-definition-search-functions*))))
1408 (defvar *central-registry* nil
1409 "A list of 'system directory designators' ASDF uses to find systems.
1411 A 'system directory designator' is a pathname or an expression
1412 which evaluates to a pathname. For example:
1414 (setf asdf:*central-registry*
1415 (list '*default-pathname-defaults*
1416 #p\"/home/me/cl/systems/\"
1417 #p\"/usr/share/common-lisp/systems/\"))
1419 This is for backward compatibilily.
1420 Going forward, we recommend new users should be using the source-registry.
1423 (defun* probe-asd (name defaults)
1425 (when (directory-pathname-p defaults)
1428 :defaults defaults :version :newest :case :local
1431 (when (probe-file* file)
1433 #+(and asdf-windows (not clisp))
1436 :defaults defaults :version :newest :case :local
1437 :name (concatenate 'string name ".asd")
1439 (when (probe-file* shortcut)
1440 (let ((target (parse-windows-shortcut shortcut)))
1442 (return (pathname target)))))))))
1444 (defun* sysdef-central-registry-search (system)
1445 (let ((name (coerce-name system))
1450 (dolist (dir *central-registry*)
1451 (let ((defaults (eval dir)))
1453 (cond ((directory-pathname-p defaults)
1454 (let ((file (probe-asd name defaults)))
1459 (let* ((*print-circle* nil)
1462 (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
1463 system dir defaults)))
1465 (remove-entry-from-registry ()
1466 :report "Remove entry from *central-registry* and continue"
1467 (push dir to-remove))
1468 (coerce-entry-to-directory ()
1470 (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
1471 (ensure-directory-pathname defaults) dir))
1472 (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
1474 (dolist (dir to-remove)
1475 (setf *central-registry* (remove dir *central-registry*)))
1476 (dolist (pair to-replace)
1477 (let* ((current (car pair))
1479 (position (position current *central-registry*)))
1480 (setf *central-registry*
1481 (append (subseq *central-registry* 0 position)
1483 (subseq *central-registry* (1+ position))))))))))
1485 (defun* make-temporary-package ()
1486 (flet ((try (counter)
1488 (make-package (format nil "~A~D" :asdf counter)
1489 :use '(:cl :asdf)))))
1490 (do* ((counter 0 (+ counter 1))
1491 (package (try counter) (try counter)))
1492 (package package))))
1494 (defun* safe-file-write-date (pathname)
1495 ;; If FILE-WRITE-DATE returns NIL, it's possible that
1496 ;; the user or some other agent has deleted an input file.
1497 ;; Also, generated files will not exist at the time planning is done
1498 ;; and calls operation-done-p which calls safe-file-write-date.
1499 ;; So it is very possible that we can't get a valid file-write-date,
1500 ;; and we can survive and we will continue the planning
1501 ;; as if the file were very old.
1502 ;; (or should we treat the case in a different, special way?)
1503 (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
1505 (when (and pathname *asdf-verbose*)
1506 (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
1510 (defmethod find-system ((name null) &optional (error-p t))
1512 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
1514 (defmethod find-system (name &optional (error-p t))
1515 (find-system (coerce-name name) error-p))
1517 (defvar *systems-being-defined* nil
1518 "A hash-table of systems currently being defined keyed by name, or NIL")
1520 (defun* find-system-if-being-defined (name)
1521 (when *systems-being-defined*
1522 (gethash (coerce-name name) *systems-being-defined*)))
1524 (defun* call-with-system-definitions (thunk)
1525 (if *systems-being-defined*
1527 (let ((*systems-being-defined* (make-hash-table :test 'equal)))
1530 (defmacro with-system-definitions (() &body body)
1531 `(call-with-system-definitions #'(lambda () ,@body)))
1533 (defun* load-sysdef (name pathname)
1534 ;; Tries to load system definition with canonical NAME from PATHNAME.
1535 (with-system-definitions ()
1536 (let ((package (make-temporary-package)))
1539 ((error #'(lambda (condition)
1540 (error 'load-system-definition-error
1541 :name name :pathname pathname
1542 :condition condition))))
1543 (let ((*package* package))
1544 (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
1547 (delete-package package)))))
1549 (defmethod find-system ((name string) &optional (error-p t))
1550 (with-system-definitions ()
1551 (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
1552 (previous (cdr in-memory))
1553 (previous (and (typep previous 'system) previous))
1554 (previous-time (car in-memory))
1555 (found (search-for-system-definition name))
1556 (found-system (and (typep found 'system) found))
1557 (pathname (or (and (typep found '(or pathname string)) (pathname found))
1558 (and found-system (system-source-file found-system))
1559 (and previous (system-source-file previous)))))
1560 (setf pathname (resolve-symlinks* pathname))
1561 (when (and pathname (not (absolute-pathname-p pathname)))
1562 (setf pathname (ensure-pathname-absolute pathname))
1564 (%set-system-source-file pathname found-system)))
1565 (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
1566 (system-source-file previous) pathname)))
1567 (%set-system-source-file pathname previous)
1568 (setf previous-time nil))
1569 (when (and found-system (not previous))
1570 (register-system found-system))
1572 (or (not previous-time)
1573 ;; don't reload if it's already been loaded,
1574 ;; or its filestamp is in the future which means some clock is skewed
1575 ;; and trying to load might cause an infinite loop.
1576 (< previous-time (safe-file-write-date pathname) (get-universal-time))))
1577 (load-sysdef name pathname))
1578 (let ((in-memory (system-registered-p name))) ; try again after loading from disk
1582 (setf (car in-memory) (safe-file-write-date pathname)))
1585 (error 'missing-component :requires name)))))))
1587 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
1588 (setf fallback (coerce-name fallback)
1589 requested (coerce-name requested))
1590 (when (equal requested fallback)
1591 (let ((registered (cdr (gethash fallback *defined-systems*))))
1593 (apply 'make-instance 'system
1594 :name fallback :source-file source-file keys)))))
1596 (defun* sysdef-find-asdf (name)
1597 ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
1598 (find-system-fallback name "asdf" :version *asdf-version*))
1601 ;;;; -------------------------------------------------------------------------
1602 ;;;; Finding components
1604 (defmethod find-component ((base string) path)
1605 (let ((s (find-system base nil)))
1606 (and s (find-component s path))))
1608 (defmethod find-component ((base symbol) path)
1610 (base (find-component (coerce-name base) path))
1611 (path (find-component path nil))
1614 (defmethod find-component ((base cons) path)
1615 (find-component (car base) (cons (cdr base) path)))
1617 (defmethod find-component ((module module) (name string))
1618 (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
1619 (compute-module-components-by-name module))
1620 (values (gethash name (module-components-by-name module))))
1622 (defmethod find-component ((component component) (name symbol))
1624 (find-component component (coerce-name name))
1627 (defmethod find-component ((module module) (name cons))
1628 (find-component (find-component module (car name)) (cdr name)))
1631 ;;; component subclasses
1633 (defclass source-file (component)
1634 ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
1636 (defclass cl-source-file (source-file)
1637 ((type :initform "lisp")))
1638 (defclass cl-source-file.cl (cl-source-file)
1639 ((type :initform "cl")))
1640 (defclass cl-source-file.lsp (cl-source-file)
1641 ((type :initform "lsp")))
1642 (defclass c-source-file (source-file)
1643 ((type :initform "c")))
1644 (defclass java-source-file (source-file)
1645 ((type :initform "java")))
1646 (defclass static-file (source-file) ())
1647 (defclass doc-file (static-file) ())
1648 (defclass html-file (doc-file)
1649 ((type :initform "html")))
1651 (defmethod source-file-type ((component module) (s module))
1652 (declare (ignorable component s))
1654 (defmethod source-file-type ((component source-file) (s module))
1655 (declare (ignorable s))
1656 (source-file-explicit-type component))
1658 (defun* coerce-pathname (name &key type defaults)
1659 "coerce NAME into a PATHNAME.
1660 When given a string, portably decompose it into a relative pathname:
1661 #\\/ separates subdirectories. The last #\\/-separated string is as follows:
1662 if TYPE is NIL, its last #\\. if any separates name and type from from type;
1663 if TYPE is a string, it is the type, and the whole string is the name;
1664 if TYPE is :DIRECTORY, the string is a directory component;
1665 if the string is empty, it's a directory.
1666 Any directory named .. is read as :BACK.
1667 Host, device and version components are taken from DEFAULTS."
1668 ;; The defaults are required notably because they provide the default host
1669 ;; to the below make-pathname, which may crucially matter to people using
1670 ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
1671 ;; NOTE that the host and device slots will be taken from the defaults,
1672 ;; but that should only matter if you later merge relative pathnames with
1673 ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
1678 (coerce-pathname (string-downcase name) :type type :defaults defaults))
1680 (multiple-value-bind (relative path filename)
1681 (component-name-to-pathname-components name :force-directory (eq type :directory)
1683 (multiple-value-bind (name type)
1685 ((or (eq type :directory) (null filename))
1688 (values filename type))
1690 (split-name-type filename)))
1691 (apply 'make-pathname :directory (cons relative path) :name name :type type
1692 ;; XCL 0.0.0.291 and ABCL 0.25 have a bug, whereby make-pathname merges directories like merge-pathnames when a :defaults is provided. Fixed in the latest XCL.
1693 (when defaults `(:defaults ,defaults))))))))
1695 (defun* merge-component-name-type (name &key type defaults)
1696 ;; For backwards compatibility only, for people using internals.
1697 ;; Will be removed in a future release, e.g. 2.016.
1698 (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
1699 (coerce-pathname name :type type :defaults defaults))
1701 (defmethod component-relative-pathname ((component component))
1703 (or (slot-value component 'relative-pathname)
1704 (component-name component))
1705 :type (source-file-type component (component-system component))
1706 :defaults (component-parent-pathname component)))
1708 ;;;; -------------------------------------------------------------------------
1711 ;;; one of these is instantiated whenever #'operate is called
1713 (defclass operation ()
1714 (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
1715 ;; T to force the inside of the specified system,
1716 ;; but not recurse to other systems we depend on.
1717 ;; :ALL (or any other atom) to force all systems
1718 ;; including other systems we depend on.
1719 ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
1720 ;; to force systems named in a given list
1721 ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
1722 (forced :initform nil :initarg :force :accessor operation-forced)
1723 (original-initargs :initform nil :initarg :original-initargs
1724 :accessor operation-original-initargs)
1725 (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
1726 (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
1727 (parent :initform nil :initarg :parent :accessor operation-parent)))
1729 (defmethod print-object ((o operation) stream)
1730 (print-unreadable-object (o stream :type t :identity t)
1732 (prin1 (operation-original-initargs o) stream))))
1734 (defmethod shared-initialize :after ((operation operation) slot-names
1737 (declare (ignorable operation slot-names force))
1738 ;; empty method to disable initarg validity checking
1741 (defun* node-for (o c)
1742 (cons (class-name (class-of o)) c))
1744 (defmethod operation-ancestor ((operation operation))
1745 (aif (operation-parent operation)
1746 (operation-ancestor it)
1750 (defun* make-sub-operation (c o dep-c dep-o)
1751 "C is a component, O is an operation, DEP-C is another
1752 component, and DEP-O, confusingly enough, is an operation
1753 class specifier, not an operation."
1754 (let* ((args (copy-list (operation-original-initargs o)))
1755 (force-p (getf args :force)))
1756 ;; note explicit comparison with T: any other non-NIL force value
1757 ;; (e.g. :recursive) will pass through
1758 (cond ((and (null (component-parent c))
1759 (null (component-parent dep-c))
1760 (not (eql c dep-c)))
1761 (when (eql force-p t)
1762 (setf (getf args :force) nil))
1763 (apply 'make-instance dep-o
1765 :original-initargs args args))
1766 ((subtypep (type-of o) dep-o)
1769 (apply 'make-instance dep-o
1770 :parent o :original-initargs args args)))))
1773 (defmethod visit-component ((o operation) (c component) data)
1774 (unless (component-visited-p o c)
1775 (setf (gethash (node-for o c)
1776 (operation-visited-nodes (operation-ancestor o)))
1779 (defmethod component-visited-p ((o operation) (c component))
1780 (gethash (node-for o c)
1781 (operation-visited-nodes (operation-ancestor o))))
1783 (defmethod (setf visiting-component) (new-value operation component)
1784 ;; MCL complains about unused lexical variables
1785 (declare (ignorable operation component))
1788 (defmethod (setf visiting-component) (new-value (o operation) (c component))
1789 (let ((node (node-for o c))
1790 (a (operation-ancestor o)))
1792 (setf (gethash node (operation-visiting-nodes a)) t)
1793 (remhash node (operation-visiting-nodes a)))
1796 (defmethod component-visiting-p ((o operation) (c component))
1797 (let ((node (node-for o c)))
1798 (gethash node (operation-visiting-nodes (operation-ancestor o)))))
1800 (defmethod component-depends-on ((op-spec symbol) (c component))
1801 ;; Note: we go from op-spec to operation via make-instance
1802 ;; to allow for specialization through defmethod's, even though
1803 ;; it's a detour in the default case below.
1804 (component-depends-on (make-instance op-spec) c))
1806 (defmethod component-depends-on ((o operation) (c component))
1807 (cdr (assoc (type-of o) (component-in-order-to c))))
1809 (defmethod component-self-dependencies ((o operation) (c component))
1810 (let ((all-deps (component-depends-on o c)))
1811 (remove-if-not #'(lambda (x)
1812 (member (component-name c) (cdr x) :test #'string=))
1815 (defmethod input-files ((operation operation) (c component))
1816 (let ((parent (component-parent c))
1817 (self-deps (component-self-dependencies operation c)))
1819 (mapcan #'(lambda (dep)
1820 (destructuring-bind (op name) dep
1821 (output-files (make-instance op)
1822 (find-component parent name))))
1824 ;; no previous operations needed? I guess we work with the
1825 ;; original source file, then
1826 (list (component-pathname c)))))
1828 (defmethod input-files ((operation operation) (c module))
1829 (declare (ignorable operation c))
1832 (defmethod component-operation-time (o c)
1833 (gethash (type-of o) (component-operation-times c)))
1835 (defmethod operation-done-p ((o operation) (c component))
1836 (let ((out-files (output-files o c))
1837 (in-files (input-files o c))
1838 (op-time (component-operation-time o c)))
1839 (flet ((earliest-out ()
1840 (reduce #'min (mapcar #'safe-file-write-date out-files)))
1842 (reduce #'max (mapcar #'safe-file-write-date in-files))))
1844 ((and (not in-files) (not out-files))
1845 ;; arbitrary decision: an operation that uses nothing to
1846 ;; produce nothing probably isn't doing much.
1847 ;; e.g. operations on systems, modules that have no immediate action,
1848 ;; but are only meaningful through traversed dependencies
1851 ;; an operation without output-files is probably meant
1852 ;; for its side-effects in the current image,
1853 ;; assumed to be idem-potent,
1854 ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
1855 (and op-time (>= op-time (latest-in))))
1857 ;; an operation without output-files and no input-files
1858 ;; is probably meant for its side-effects on the file-system,
1859 ;; assumed to have to be done everytime.
1860 ;; (I don't think there is any such case in ASDF unless extended)
1863 ;; an operation with both input and output files is assumed
1864 ;; as computing the latter from the former,
1865 ;; assumed to have been done if the latter are all older
1867 ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
1868 ;; We use >= instead of > to play nice with generated files.
1869 ;; This opens a race condition if an input file is changed
1870 ;; after the output is created but within the same second
1871 ;; of filesystem time; but the same race condition exists
1872 ;; whenever the computation from input to output takes more
1873 ;; than one second of filesystem time (or just crosses the
1874 ;; second). So that's cool.
1876 (every #'probe-file* in-files)
1877 (every #'probe-file* out-files)
1878 (>= (earliest-out) (latest-in))))))))
1882 ;;; For 1.700 I've done my best to refactor TRAVERSE
1883 ;;; by splitting it up in a bunch of functions,
1884 ;;; so as to improve the collection and use-detection algorithm. --fare
1885 ;;; The protocol is as follows: we pass around operation, dependency,
1886 ;;; bunch of other stuff, and a force argument. Return a force flag.
1887 ;;; The returned flag is T if anything has changed that requires a rebuild.
1888 ;;; The force argument is a list of components that will require a rebuild
1889 ;;; if the flag is T, at which point whoever returns the flag has to
1890 ;;; mark them all as forced, and whoever recurses again can use a NIL list
1891 ;;; as a further argument.
1893 (defvar *forcing* nil
1894 "This dynamically-bound variable is used to force operations in
1895 recursive calls to traverse.")
1897 (defgeneric* do-traverse (operation component collect))
1899 (defun* %do-one-dep (operation c collect required-op required-c required-v)
1900 ;; collects a partial plan that results from performing required-op
1901 ;; on required-c, possibly with a required-vERSION
1902 (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
1903 (and d (version-satisfies d required-v) d))
1905 (error 'missing-dependency-of-version
1908 :requires required-c)
1909 (error 'missing-dependency
1911 :requires required-c))))
1912 (op (make-sub-operation c operation dep-c required-op)))
1913 (do-traverse op dep-c collect)))
1915 (defun* do-one-dep (operation c collect required-op required-c required-v)
1916 ;; this function is a thin, error-handling wrapper around %do-one-dep.
1917 ;; Collects a partial plan per that function.
1920 (return (%do-one-dep operation c collect
1921 required-op required-c required-v))
1924 (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
1928 (and (typep c 'missing-dependency)
1929 (equalp (missing-requires c)
1932 (defun* do-dep (operation c collect op dep)
1933 ;; type of arguments uncertain:
1934 ;; op seems to at least potentially be a symbol, rather than an operation
1935 ;; dep is a list of component names
1936 (cond ((eq op 'feature)
1937 (if (member (car dep) *features*)
1939 (error 'missing-dependency
1941 :requires (car dep))))
1944 (flet ((dep (op comp ver)
1945 (when (do-one-dep operation c collect
1951 ;; structured dependencies --- this parses keywords
1952 ;; the keywords could be broken out and cleanly (extensibly)
1953 ;; processed by EQL methods
1954 (cond ((eq :version (first d))
1955 ;; https://bugs.launchpad.net/asdf/+bug/527788
1956 (dep op (second d) (third d)))
1957 ;; This particular subform is not documented and
1958 ;; has always been broken in the past.
1959 ;; Therefore no one uses it, and I'm cerroring it out,
1961 ;; See https://bugs.launchpad.net/asdf/+bug/518467
1962 ((eq :feature (first d))
1963 (cerror "Continue nonetheless."
1964 "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
1965 (when (find (second d) *features* :test 'string-equal)
1966 (dep op (third d) nil)))
1968 (error (compatfmt "~@<Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))
1971 (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
1973 (defun* do-collect (collect x)
1974 (funcall collect x))
1976 (defmethod do-traverse ((operation operation) (c component) collect)
1977 (let ((*forcing* *forcing*)
1978 (flag nil)) ;; return value: must we rebuild this and its dependencies?
1983 (update-flag (do-dep operation c collect op comp))))
1984 ;; Have we been visited yet? If so, just process the result.
1985 (aif (component-visited-p operation c)
1987 (update-flag (cdr it))
1988 (return-from do-traverse flag)))
1990 (when (component-visiting-p operation c)
1991 (error 'circular-dependency :components (list c)))
1992 (setf (visiting-component operation c) t)
1995 (let ((f (operation-forced
1996 (operation-ancestor operation))))
1997 (when (and f (or (not (consp f)) ;; T or :ALL
1998 (and (typep c 'system) ;; list of names of systems to force
1999 (member (component-name c) f
2001 (setf *forcing* t)))
2002 ;; first we check and do all the dependencies for the module.
2003 ;; Operations planned in this loop will show up
2004 ;; in the results, and are consumed below.
2005 (let ((*forcing* nil))
2006 ;; upstream dependencies are never forced to happen just because
2007 ;; the things that depend on them are....
2009 :for (required-op . deps) :in (component-depends-on operation c)
2010 :do (dep required-op deps)))
2013 (when (typep c 'module)
2014 (let ((at-least-one nil)
2015 ;; This is set based on the results of the
2016 ;; dependencies and whether we are in the
2017 ;; context of a *forcing* call...
2018 ;; inter-system dependencies do NOT trigger
2019 ;; building components
2022 (and flag (not (typep c 'system)))))
2024 (while-collecting (internal-collect)
2025 (dolist (kid (module-components c))
2028 (do-traverse operation kid #'internal-collect))
2029 (missing-dependency (condition)
2030 (when (eq (module-if-component-dep-fails c)
2033 (setf error condition))
2035 (declare (ignore c))
2036 (setf at-least-one t))))
2037 (when (and (eq (module-if-component-dep-fails c)
2041 (update-flag (or *forcing* (not (operation-done-p operation c))))
2042 ;; For sub-operations, check whether
2043 ;; the original ancestor operation was forced,
2044 ;; or names us amongst an explicit list of things to force...
2045 ;; except that this check doesn't distinguish
2046 ;; between all the things with a given name. Sigh.
2049 (let ((do-first (cdr (assoc (class-name (class-of operation))
2050 (component-do-first c)))))
2051 (loop :for (required-op . deps) :in do-first
2052 :do (do-dep operation c collect required-op deps)))
2053 (do-collect collect (vector module-ops))
2054 (do-collect collect (cons operation c)))))
2055 (setf (visiting-component operation c) nil)))
2056 (visit-component operation c (when flag (incf *visit-count*)))
2059 (defun* flatten-tree (l)
2060 ;; You collected things into a list.
2061 ;; Most elements are just things to collect again.
2062 ;; A (simple-vector 1) indicate that you should recurse into its contents.
2063 ;; This way, in two passes (rather than N being the depth of the tree),
2064 ;; you can collect things with marginally constant-time append,
2065 ;; achieving linear time collection instead of quadratic time.
2066 (while-collecting (c)
2068 (if (typep x '(simple-vector 1))
2072 (dolist (x l) (r x))))
2075 (defmethod traverse ((operation operation) (c component))
2076 (when (consp (operation-forced operation))
2077 (setf (operation-forced operation)
2078 (mapcar #'coerce-name (operation-forced operation))))
2080 (while-collecting (collect)
2081 (let ((*visit-count* 0))
2082 (do-traverse operation c #'collect)))))
2084 (defmethod perform ((operation operation) (c source-file))
2086 (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
2087 (class-of operation) (class-of c)))
2089 (defmethod perform ((operation operation) (c module))
2090 (declare (ignorable operation c))
2093 (defmethod explain ((operation operation) (component component))
2094 (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
2095 (operation-description operation component)))
2097 (defmethod operation-description (operation component)
2098 (format nil (compatfmt "~@<~A on ~A~@:>")
2099 (class-of operation) component))
2101 ;;;; -------------------------------------------------------------------------
2104 (defclass compile-op (operation)
2105 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
2106 (on-warnings :initarg :on-warnings :accessor operation-on-warnings
2107 :initform *compile-file-warnings-behaviour*)
2108 (on-failure :initarg :on-failure :accessor operation-on-failure
2109 :initform *compile-file-failure-behaviour*)
2110 (flags :initarg :flags :accessor compile-op-flags
2113 (defun output-file (operation component)
2114 "The unique output file of performing OPERATION on COMPONENT"
2115 (let ((files (output-files operation component)))
2116 (assert (length=n-p files 1))
2119 (defmethod perform :before ((operation compile-op) (c source-file))
2120 (loop :for file :in (asdf:output-files operation c)
2121 :for pathname = (if (typep file 'logical-pathname)
2122 (translate-logical-pathname file)
2124 :do (ensure-directories-exist pathname)))
2126 (defmethod perform :after ((operation operation) (c component))
2127 (setf (gethash (type-of operation) (component-operation-times c))
2128 (get-universal-time)))
2130 (defvar *compile-op-compile-file-function* 'compile-file*
2131 "Function used to compile lisp files.")
2133 ;;; perform is required to check output-files to find out where to put
2134 ;;; its answers, in case it has been overridden for site policy
2135 (defmethod perform ((operation compile-op) (c cl-source-file))
2136 #-:broken-fasl-loader
2137 (let ((source-file (component-pathname c))
2138 ;; on some implementations, there are more than one output-file,
2139 ;; but the first one should always be the primary fasl that gets loaded.
2140 (output-file (first (output-files operation c)))
2141 (*compile-file-warnings-behaviour* (operation-on-warnings operation))
2142 (*compile-file-failure-behaviour* (operation-on-failure operation)))
2143 (multiple-value-bind (output warnings-p failure-p)
2144 (apply *compile-op-compile-file-function* source-file :output-file output-file
2145 (compile-op-flags operation))
2147 (case (operation-on-warnings operation)
2149 (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
2151 (:error (error 'compile-warned :component c :operation operation))
2154 (case (operation-on-failure operation)
2156 (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
2158 (:error (error 'compile-failed :component c :operation operation))
2161 (error 'compile-error :component c :operation operation)))))
2163 (defmethod output-files ((operation compile-op) (c cl-source-file))
2164 (declare (ignorable operation))
2165 (let ((p (lispize-pathname (component-pathname c))))
2166 #-broken-fasl-loader (list (compile-file-pathname p))
2167 #+broken-fasl-loader (list p)))
2169 (defmethod perform ((operation compile-op) (c static-file))
2170 (declare (ignorable operation c))
2173 (defmethod output-files ((operation compile-op) (c static-file))
2174 (declare (ignorable operation c))
2177 (defmethod input-files ((operation compile-op) (c static-file))
2178 (declare (ignorable operation c))
2181 (defmethod operation-description ((operation compile-op) component)
2182 (declare (ignorable operation))
2183 (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
2185 (defmethod operation-description ((operation compile-op) (component module))
2186 (declare (ignorable operation))
2187 (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
2190 ;;;; -------------------------------------------------------------------------
2193 (defclass basic-load-op (operation) ())
2195 (defclass load-op (basic-load-op) ())
2197 (defmethod perform ((o load-op) (c cl-source-file))
2198 (map () #'load (input-files o c)))
2200 (defmethod perform-with-restarts (operation component)
2201 ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
2202 (perform operation component))
2204 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
2205 (declare (ignorable o))
2206 (loop :with state = :initial
2207 :until (or (eq state :success)
2208 (eq state :failure)) :do
2211 (setf state :failure)
2213 (setf state :success))
2215 (setf state :recompiled)
2216 (perform (make-sub-operation c o c 'compile-op) c))
2218 (with-simple-restart
2219 (try-recompiling "Recompile ~a and try loading it again"
2221 (setf state :failed-load)
2223 (setf state :success))))))
2225 (defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
2226 (loop :with state = :initial
2227 :until (or (eq state :success)
2228 (eq state :failure)) :do
2231 (setf state :failure)
2233 (setf state :success))
2235 (setf state :recompiled)
2236 (perform-with-restarts o c))
2238 (with-simple-restart
2239 (try-recompiling "Try recompiling ~a"
2241 (setf state :failed-compile)
2243 (setf state :success))))))
2245 (defmethod perform ((operation load-op) (c static-file))
2246 (declare (ignorable operation c))
2249 (defmethod operation-done-p ((operation load-op) (c static-file))
2250 (declare (ignorable operation c))
2253 (defmethod output-files ((operation operation) (c component))
2254 (declare (ignorable operation c))
2257 (defmethod component-depends-on ((operation load-op) (c component))
2258 (declare (ignorable operation))
2259 (cons (list 'compile-op (component-name c))
2260 (call-next-method)))
2262 (defmethod operation-description ((operation load-op) component)
2263 (declare (ignorable operation))
2264 (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
2267 (defmethod operation-description ((operation load-op) (component cl-source-file))
2268 (declare (ignorable operation))
2269 (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
2272 (defmethod operation-description ((operation load-op) (component module))
2273 (declare (ignorable operation))
2274 (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
2277 ;;;; -------------------------------------------------------------------------
2280 (defclass load-source-op (basic-load-op) ())
2282 (defmethod perform ((o load-source-op) (c cl-source-file))
2283 (declare (ignorable o))
2284 (let ((source (component-pathname c)))
2285 (setf (component-property c 'last-loaded-as-source)
2287 (get-universal-time)))))
2289 (defmethod perform ((operation load-source-op) (c static-file))
2290 (declare (ignorable operation c))
2293 (defmethod output-files ((operation load-source-op) (c component))
2294 (declare (ignorable operation c))
2297 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
2298 (defmethod component-depends-on ((o load-source-op) (c component))
2299 (declare (ignorable o))
2300 (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
2301 :for (op . co) :in what-would-load-op-do
2302 :when (eq op 'load-op) :collect (cons 'load-source-op co)))
2304 (defmethod operation-done-p ((o load-source-op) (c source-file))
2305 (declare (ignorable o))
2306 (if (or (not (component-property c 'last-loaded-as-source))
2307 (> (safe-file-write-date (component-pathname c))
2308 (component-property c 'last-loaded-as-source)))
2311 (defmethod operation-description ((operation load-source-op) component)
2312 (declare (ignorable operation))
2313 (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
2316 (defmethod operation-description ((operation load-source-op) (component module))
2317 (declare (ignorable operation))
2318 (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
2321 ;;;; -------------------------------------------------------------------------
2324 (defclass test-op (operation) ())
2326 (defmethod perform ((operation test-op) (c component))
2327 (declare (ignorable operation c))
2330 (defmethod operation-done-p ((operation test-op) (c system))
2331 "Testing a system is _never_ done."
2332 (declare (ignorable operation c))
2335 (defmethod component-depends-on :around ((o test-op) (c system))
2336 (declare (ignorable o))
2337 (cons `(load-op ,(component-name c)) (call-next-method)))
2340 ;;;; -------------------------------------------------------------------------
2341 ;;;; Invoking Operations
2343 (defgeneric* operate (operation-class system &key &allow-other-keys))
2344 (defgeneric* perform-plan (plan &key))
2346 ;;;; Try to upgrade of ASDF. If a different version was used, return T.
2347 ;;;; We need do that before we operate on anything that depends on ASDF.
2348 (defun* upgrade-asdf ()
2349 (let ((version (asdf:asdf-version)))
2350 (handler-bind (((or style-warning warning) #'muffle-warning))
2351 (operate 'load-op :asdf :verbose nil))
2352 (let ((new-version (asdf:asdf-version)))
2355 ((equal version new-version)
2357 ((version-satisfies new-version version)
2358 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
2359 version new-version))
2360 ((version-satisfies version new-version)
2361 (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
2362 version new-version))
2364 (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
2365 version new-version)))
2366 (let ((asdf (find-system :asdf)))
2367 ;; invalidate all systems but ASDF itself
2368 (setf *defined-systems* (make-defined-systems-table))
2369 (register-system asdf)
2372 (defmethod perform-plan ((steps list) &key)
2373 (let ((*package* *package*)
2374 (*readtable* *readtable*))
2375 (with-compilation-unit ()
2376 (loop :for (op . component) :in steps :do
2380 (perform-with-restarts op component)
2385 (format s (compatfmt "~@<Retry ~A.~@:>")
2386 (operation-description op component))))
2390 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
2391 (operation-description op component)))
2392 (setf (gethash (type-of op)
2393 (component-operation-times component))
2394 (get-universal-time))
2397 (defmethod operate (operation-class system &rest args
2398 &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
2400 (declare (ignore force))
2401 (with-system-definitions ()
2402 (let* ((op (apply 'make-instance operation-class
2403 :original-initargs args
2405 (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
2406 (system (etypecase system
2408 ((or string symbol) (find-system system)))))
2409 (unless (version-satisfies system version)
2410 (error 'missing-component-of-version :requires system :version version))
2411 (let ((steps (traverse op system)))
2412 (when (and (not (equal '("asdf") (component-find-path system)))
2413 (find-if #'(lambda (x) (equal '("asdf")
2414 (component-find-path (cdr x))))
2417 ;; If we needed to upgrade ASDF to achieve our goal,
2418 ;; then do it specially as the first thing, then
2419 ;; invalidate all existing system
2420 ;; retry the whole thing with the new OPERATE function,
2421 ;; which on some implementations
2422 ;; has a new symbol shadowing the current one.
2423 (return-from operate
2424 (apply (find-symbol* 'operate :asdf) operation-class system args)))
2425 (perform-plan steps)
2426 (values op steps)))))
2428 (defun* oos (operation-class system &rest args &key force verbose version
2430 (declare (ignore force verbose version))
2431 (apply 'operate operation-class system args))
2433 (let ((operate-docstring
2434 "Operate does three things:
2436 1. It creates an instance of OPERATION-CLASS using any keyword parameters
2438 2. It finds the asdf-system specified by SYSTEM (possibly loading
2440 3. It then calls TRAVERSE with the operation and system as arguments
2442 The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
2443 handling code. If a VERSION argument is supplied, then operate also
2444 ensures that the system found satisfies it using the VERSION-SATISFIES
2447 Note that dependencies may cause the operation to invoke other
2448 operations on the system or its components: the new operations will be
2449 created with the same initargs as the original one.
2451 (setf (documentation 'oos 'function)
2453 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
2455 (setf (documentation 'operate 'function)
2458 (defun* load-system (system &rest args &key force verbose version &allow-other-keys)
2459 "Shorthand for `(operate 'asdf:load-op system)`.
2460 See OPERATE for details."
2461 (declare (ignore force verbose version))
2462 (apply 'operate 'load-op system args)
2465 (defun* compile-system (system &rest args &key force verbose version
2467 "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
2469 (declare (ignore force verbose version))
2470 (apply 'operate 'compile-op system args)
2473 (defun* test-system (system &rest args &key force verbose version
2475 "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
2477 (declare (ignore force verbose version))
2478 (apply 'operate 'test-op system args)
2481 ;;;; -------------------------------------------------------------------------
2484 (defun* load-pathname ()
2485 (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
2487 (defun* determine-system-pathname (pathname pathname-supplied-p)
2488 ;; The defsystem macro calls us to determine
2489 ;; the pathname of a system as follows:
2490 ;; 1. the one supplied,
2491 ;; 2. derived from *load-pathname* via load-pathname
2492 ;; 3. taken from the *default-pathname-defaults* via default-directory
2493 (let* ((file-pathname (load-pathname))
2494 (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
2495 (or (and pathname-supplied-p
2496 (merge-pathnames* (coerce-pathname pathname :type :directory)
2497 directory-pathname))
2499 (default-directory))))
2501 (defun* class-for-type (parent type)
2502 (or (loop :for symbol :in (list
2504 (find-symbol* type *package*)
2505 (find-symbol* type :asdf))
2506 :for class = (and symbol (find-class symbol nil))
2508 (#-cormanlisp subtypep #+cormanlisp cl::subclassp
2509 class (find-class 'component)))
2511 (and (eq type :file)
2512 (or (module-default-component-class parent)
2513 (find-class *default-component-class*)))
2514 (sysdef-error "don't recognize component type ~A" type)))
2516 (defun* maybe-add-tree (tree op1 op2 c)
2517 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
2518 Returns the new tree (which probably shares structure with the old one)"
2519 (let ((first-op-tree (assoc op1 tree)))
2522 (aif (assoc op2 (cdr first-op-tree))
2523 (if (find c (cdr it))
2525 (setf (cdr it) (cons c (cdr it))))
2526 (setf (cdr first-op-tree)
2527 (acons op2 (list c) (cdr first-op-tree))))
2529 (acons op1 (list (list op2 c)) tree))))
2531 (defun* union-of-dependencies (&rest deps)
2532 (let ((new-tree nil))
2534 (dolist (op-tree dep)
2535 (dolist (op (cdr op-tree))
2536 (dolist (c (cdr op))
2538 (maybe-add-tree new-tree (car op-tree) (car op) c))))))
2542 (defvar *serial-depends-on* nil)
2544 (defun* sysdef-error-component (msg type name value)
2545 (sysdef-error (concatenate 'string msg
2546 (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
2549 (defun* check-component-input (type name weakly-depends-on
2550 depends-on components in-order-to)
2551 "A partial test of the values of a component."
2552 (unless (listp depends-on)
2553 (sysdef-error-component ":depends-on must be a list."
2554 type name depends-on))
2555 (unless (listp weakly-depends-on)
2556 (sysdef-error-component ":weakly-depends-on must be a list."
2557 type name weakly-depends-on))
2558 (unless (listp components)
2559 (sysdef-error-component ":components must be NIL or a list of components."
2560 type name components))
2561 (unless (and (listp in-order-to) (listp (car in-order-to)))
2562 (sysdef-error-component ":in-order-to must be NIL or a list of components."
2563 type name in-order-to)))
2565 (defun* %remove-component-inline-methods (component)
2566 (dolist (name +asdf-methods+)
2568 ;; this is inefficient as most of the stored
2569 ;; methods will not be for this particular gf
2570 ;; But this is hardly performance-critical
2572 (remove-method (symbol-function name) m))
2573 (component-inline-methods component)))
2574 ;; clear methods, then add the new ones
2575 (setf (component-inline-methods component) nil))
2577 (defun* %define-component-inline-methods (ret rest)
2578 (dolist (name +asdf-methods+)
2579 (let ((keyword (intern (symbol-name name) :keyword)))
2580 (loop :for data = rest :then (cddr data)
2581 :for key = (first data)
2582 :for value = (second data)
2584 :when (eq key keyword) :do
2585 (destructuring-bind (op qual (o c) &body body) value
2587 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
2589 (component-inline-methods ret)))))))
2591 (defun* %refresh-component-inline-methods (component rest)
2592 (%remove-component-inline-methods component)
2593 (%define-component-inline-methods component rest))
2595 (defun* parse-component-form (parent options)
2597 (type name &rest rest &key
2598 ;; the following list of keywords is reproduced below in the
2599 ;; remove-keys form. important to keep them in sync
2600 components pathname default-component-class
2601 perform explain output-files operation-done-p
2603 depends-on serial in-order-to
2604 (version nil versionp)
2606 &allow-other-keys) options
2607 (declare (ignorable perform explain output-files operation-done-p))
2608 (check-component-input type name weakly-depends-on depends-on components in-order-to)
2611 (find-component parent name)
2612 ;; ignore the same object when rereading the defsystem
2614 (typep (find-component parent name)
2615 (class-for-type parent type))))
2616 (error 'duplicate-names :name name))
2619 (unless (parse-version version nil)
2620 (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
2621 version name parent)))
2623 (let* ((other-args (remove-keys
2624 '(components pathname default-component-class
2625 perform explain output-files operation-done-p
2627 depends-on serial in-order-to)
2630 (or (find-component parent name)
2631 (make-instance (class-for-type parent type)))))
2632 (when weakly-depends-on
2633 (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
2634 (when *serial-depends-on*
2635 (push *serial-depends-on* depends-on))
2636 (apply 'reinitialize-instance ret
2637 :name (coerce-name name)
2641 (component-pathname ret) ; eagerly compute the absolute pathname
2642 (when (typep ret 'module)
2643 (setf (module-default-component-class ret)
2644 (or default-component-class
2645 (and (typep parent 'module)
2646 (module-default-component-class parent))))
2647 (let ((*serial-depends-on* nil))
2648 (setf (module-components ret)
2650 :for c-form :in components
2651 :for c = (parse-component-form ret c-form)
2652 :for name = (component-name c)
2654 :when serial :do (setf *serial-depends-on* name))))
2655 (compute-module-components-by-name ret))
2657 (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
2659 (setf (component-in-order-to ret)
2660 (union-of-dependencies
2662 `((compile-op (compile-op ,@depends-on))
2663 (load-op (load-op ,@depends-on)))))
2664 (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
2666 (%refresh-component-inline-methods ret rest)
2669 (defun* do-defsystem (name &rest options
2670 &key (pathname nil pathname-arg-p) (class 'system)
2671 defsystem-depends-on &allow-other-keys)
2672 ;; The system must be registered before we parse the body,
2673 ;; otherwise we recur when trying to find an existing system
2674 ;; of the same name to reuse options (e.g. pathname) from.
2675 ;; To avoid infinite recursion in cases where you defsystem a system
2676 ;; that is registered to a different location to find-system,
2677 ;; we also need to remember it in a special variable *systems-being-defined*.
2678 (with-system-definitions ()
2679 (let* ((name (coerce-name name))
2680 (registered (system-registered-p name))
2681 (system (cdr (or registered
2682 (register-system (make-instance 'system :name name)))))
2683 (component-options (remove-keys '(:class) options)))
2684 (%set-system-source-file (load-pathname) system)
2685 (setf (gethash name *systems-being-defined*) system)
2687 (setf (car registered) (get-universal-time)))
2688 (map () 'load-system defsystem-depends-on)
2689 ;; We change-class (when necessary) AFTER we load the defsystem-dep's
2690 ;; since the class might not be defined as part of those.
2691 (unless (eq (type-of system) class)
2692 (change-class system class))
2693 (parse-component-form
2696 :pathname (determine-system-pathname pathname pathname-arg-p)
2697 component-options)))))
2699 (defmacro defsystem (name &body options)
2700 `(apply 'do-defsystem ',name ',options))
2702 ;;;; ---------------------------------------------------------------------------
2703 ;;;; run-shell-command
2705 ;;;; run-shell-command functions for other lisp implementations will be
2706 ;;;; gratefully accepted, if they do the same thing.
2707 ;;;; If the docstring is ambiguous, send a bug report.
2709 ;;;; We probably should move this functionality to its own system and deprecate
2710 ;;;; use of it from the asdf package. However, this would break unspecified
2711 ;;;; existing software, so until a clear alternative exists, we can't deprecate
2712 ;;;; it, and even after it's been deprecated, we will support it for a few
2713 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
2715 (defun* run-shell-command (control-string &rest args)
2716 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
2717 synchronously execute the result using a Bourne-compatible shell, with
2718 output to *VERBOSE-OUT*. Returns the shell's exit code."
2719 (let ((command (apply 'format nil control-string args)))
2720 (asdf-message "; $ ~A~%" command)
2723 (ext:run-shell-command command :output *verbose-out*)
2726 ;; will this fail if command has embedded quotes - it seems to work
2727 (multiple-value-bind (stdout stderr exit-code)
2728 (excl.osi:command-output
2729 (format nil "~a -c \"~a\""
2730 #+mswindows "sh" #-mswindows "/bin/sh" command)
2731 :input nil :whole nil
2732 #+mswindows :show-window #+mswindows :hide)
2733 (asdf-message "~{~&; ~a~%~}~%" stderr)
2734 (asdf-message "~{~&; ~a~%~}~%" stdout)
2737 #+clisp ;XXX not exactly *verbose-out*, I know
2738 (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
2742 (ccl:external-process-status
2743 (ccl:run-program "/bin/sh" (list "-c" command)
2744 :input nil :output *verbose-out*
2747 #+ecl ;; courtesy of Juan Jose Garcia Ripoll
2751 (lisp:system command)
2754 (system:call-system-showing-output
2756 :shell-type "/bin/sh"
2759 :output-stream *verbose-out*)
2762 (sb-ext:process-exit-code
2763 (apply 'sb-ext:run-program
2764 #+win32 "sh" #-win32 "/bin/sh"
2766 :input nil :output *verbose-out*
2767 #+win32 '(:search t) #-win32 nil))
2770 (ext:process-exit-code
2774 :input nil :output *verbose-out*))
2777 (ext:run-shell-command command)
2779 #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
2780 (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
2782 ;;;; ---------------------------------------------------------------------------
2783 ;;;; system-relative-pathname
2785 (defun* system-definition-pathname (x)
2786 ;; As of 2.014.8, we mean to make this function obsolete,
2787 ;; but that won't happen until all clients have been updated.
2788 ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
2789 "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
2790 It used to expose ASDF internals with subtle differences with respect to
2791 user expectations, that have been refactored away since.
2792 We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
2793 for a mostly compatible replacement that we're supporting,
2794 or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
2795 if that's whay you mean." ;;)
2796 (system-source-file x))
2798 (defmethod system-source-file ((system-name string))
2799 (system-source-file (find-system system-name)))
2800 (defmethod system-source-file ((system-name symbol))
2801 (system-source-file (find-system system-name)))
2803 (defun* system-source-directory (system-designator)
2804 "Return a pathname object corresponding to the
2805 directory in which the system specification (.asd file) is
2807 (make-pathname :name nil
2809 :defaults (system-source-file system-designator)))
2811 (defun* relativize-directory (directory)
2813 ((stringp directory)
2814 (list :relative directory))
2815 ((eq (car directory) :absolute)
2816 (cons :relative (cdr directory)))
2820 (defun* relativize-pathname-directory (pathspec)
2821 (let ((p (pathname pathspec)))
2823 :directory (relativize-directory (pathname-directory p))
2826 (defun* system-relative-pathname (system name &key type)
2828 (coerce-pathname name :type type)
2829 (system-source-directory system)))
2832 ;;; ---------------------------------------------------------------------------
2833 ;;; implementation-identifier
2835 ;;; produce a string to identify current implementation.
2836 ;;; Initially stolen from SLIME's SWANK, hacked since.
2838 (defparameter *implementation-features*
2839 '((:abcl :armedbear)
2841 (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
2843 (:corman :cormanlisp)
2845 :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
2847 (defparameter *os-features*
2848 '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
2850 (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
2851 (:macosx :darwin :darwin-target :apple)
2852 :freebsd :netbsd :openbsd :bsd
2856 (defparameter *architecture-features*
2857 '((:amd64 :x86-64 :x86_64 :x8664-target)
2858 (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
2860 (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
2861 :sparc64 (:sparc32 :sparc)
2863 (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
2864 :mipsel :mipseb :mips
2868 (defun* lisp-version-string ()
2869 (let ((s (lisp-implementation-version)))
2870 (declare (ignorable s))
2871 #+allegro (format nil
2873 excl::*common-lisp-version-number*
2874 ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
2875 (if (eq excl:*current-case-mode*
2876 :case-sensitive-lower) "M" "A")
2877 ;; Note if not using International ACL
2878 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
2879 (excl:ics-target-case
2882 (if (member :64bit *features*) "-64bit" ""))
2883 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
2884 #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
2885 #+clozure (format nil "~d.~d-f~d" ; shorten for windows
2886 ccl::*openmcl-major-version*
2887 ccl::*openmcl-minor-version*
2888 (logand ccl::fasl-version #xFF))
2889 #+cmu (substitute #\- #\/ s)
2890 #+ecl (format nil "~A~@[-~A~]" s
2891 (let ((vcs-id (ext:lisp-implementation-vcs-id)))
2892 (when (>= (length vcs-id) 8)
2893 (subseq vcs-id 0 8))))
2894 #+gcl (subseq s (1+ (position #\space s)))
2895 #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
2896 (format nil "~D.~D" major minor))
2897 #+lispworks (format nil "~A~@[~A~]" s
2898 (when (member :lispworks-64bit *features*) "-64bit"))
2899 ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
2900 #+mcl (subseq s 8) ; strip the leading "Version "
2901 #+(or cormanlisp sbcl scl) s
2902 #-(or allegro armedbear clisp clozure cmu cormanlisp
2903 ecl gcl genera lispworks mcl sbcl scl) s))
2905 (defun* first-feature (features)
2910 (let ((feature (find thing *features*)))
2911 (when feature (return-from fp feature))))
2912 ;; allows features to be lists of which the first
2913 ;; member is the "main name", the rest being aliases
2915 (dolist (subf thing)
2916 (when (find subf *features*) (return-from fp (first thing))))))
2918 (loop :for f :in features
2919 :when (fp f) :return :it)))
2921 (defun* implementation-type ()
2922 (first-feature *implementation-features*))
2924 (defun* implementation-identifier ()
2926 ((maybe-warn (value fstring &rest args)
2928 (t (apply 'warn fstring args)
2930 (let ((lisp (maybe-warn (implementation-type)
2931 (compatfmt "~@<No implementation feature found in ~a.~@:>")
2932 *implementation-features*))
2933 (os (maybe-warn (first-feature *os-features*)
2934 (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))
2936 (maybe-warn (first-feature *architecture-features*)
2937 (compatfmt "~@<No architecture feature found in ~a.~@:>")
2938 *architecture-features*)))
2939 (version (maybe-warn (lisp-version-string)
2940 "Don't know how to get Lisp implementation version.")))
2942 #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
2943 (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
2946 ;;; ---------------------------------------------------------------------------
2947 ;;; Generic support for configuration files
2949 (defparameter *inter-directory-separator*
2953 (defun* user-homedir ()
2954 (truenamize (pathname-directory-pathname (user-homedir-pathname))))
2956 (defun* try-directory-subpath (x sub &key type)
2957 (let* ((p (and x (ensure-directory-pathname x)))
2958 (tp (and p (probe-file* p)))
2959 (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
2960 (ts (and sp (probe-file* sp))))
2961 (and ts (values sp ts))))
2962 (defun* user-configuration-directories ()
2965 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
2966 `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
2967 ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
2968 :for dir :in (split-string dirs :separator ":")
2969 :collect (try dir "common-lisp/"))
2971 ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
2972 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
2973 ,(try (getenv "APPDATA") "common-lisp/config/"))
2974 ,(try (user-homedir) ".config/common-lisp/")))))
2975 (defun* system-configuration-directories ()
2980 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
2981 `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
2982 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
2983 ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
2985 (list #p"/etc/common-lisp/"))))
2986 (defun* in-first-directory (dirs x)
2987 (loop :for dir :in dirs
2988 :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
2989 (defun* in-user-configuration-directory (x)
2990 (in-first-directory (user-configuration-directories) x))
2991 (defun* in-system-configuration-directory (x)
2992 (in-first-directory (system-configuration-directories) x))
2994 (defun* configuration-inheritance-directive-p (x)
2995 (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
2997 (and (length=n-p x 1) (member (car x) kw)))))
2999 (defun* report-invalid-form (reporter &rest args)
3002 (apply 'error 'invalid-configuration args))
3004 (apply reporter args))
3006 (apply 'error reporter args))
3008 (apply 'apply (append reporter args)))))
3010 (defvar *ignored-configuration-form* nil)
3012 (defun* validate-configuration-form (form tag directive-validator
3013 &key location invalid-form-reporter)
3014 (unless (and (consp form) (eq (car form) tag))
3015 (setf *ignored-configuration-form* t)
3016 (report-invalid-form invalid-form-reporter :form form :location location)
3017 (return-from validate-configuration-form nil))
3018 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
3019 :for directive :in (cdr form)
3021 ((configuration-inheritance-directive-p directive)
3023 ((eq directive :ignore-invalid-entries)
3024 (setf ignore-invalid-p t) t)
3025 ((funcall directive-validator directive)
3030 (setf *ignored-configuration-form* t)
3031 (report-invalid-form invalid-form-reporter :form directive :location location)
3033 :do (push directive x)
3035 (unless (= inherit 1)
3036 (report-invalid-form invalid-form-reporter
3037 :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
3038 :inherit-configuration :ignore-inherited-configuration)))
3039 (return (nreverse x))))
3041 (defun* validate-configuration-file (file validator &key description)
3042 (let ((forms (read-file-forms file)))
3043 (unless (length=n-p forms 1)
3044 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
3046 (funcall validator (car forms) :location file)))
3048 (defun* hidden-file-p (pathname)
3049 (equal (first-char (pathname-name pathname)) #\.))
3051 (defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
3052 (apply 'directory pathname-spec
3053 (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
3054 #+clozure '(:follow-links nil)
3055 #+clisp '(:circle t :if-does-not-exist :ignore)
3056 #+(or cmu scl) '(:follow-links nil :truenamep nil)
3057 #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
3059 (defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
3060 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
3061 be applied to the results to yield a configuration form. Current
3062 values of TAG include :source-registry and :output-translations."
3063 (let ((files (sort (ignore-errors
3066 (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
3067 #'string< :key #'namestring)))
3069 ,@(loop :for file :in files :append
3070 (loop :with ignore-invalid-p = nil
3071 :for form :in (read-file-forms file)
3072 :when (eq form :ignore-invalid-entries)
3073 :do (setf ignore-invalid-p t)
3075 :when (funcall validator form)
3078 :when ignore-invalid-p
3079 :do (setf *ignored-configuration-form* t)
3081 :do (report-invalid-form invalid-form-reporter :form form :location file)))
3082 :inherit-configuration)))
3085 ;;; ---------------------------------------------------------------------------
3086 ;;; asdf-output-translations
3088 ;;; this code is heavily inspired from
3089 ;;; asdf-binary-translations, common-lisp-controller and cl-launch.
3090 ;;; ---------------------------------------------------------------------------
3092 (defvar *output-translations* ()
3093 "Either NIL (for uninitialized), or a list of one element,
3094 said element itself being a sorted list of mappings.
3095 Each mapping is a pair of a source pathname and destination pathname,
3096 and the order is by decreasing length of namestring of the source pathname.")
3098 (defvar *user-cache*
3099 (flet ((try (x &rest sub) (and x `(,x ,@sub))))
3101 (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
3103 (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
3104 '(:home ".cache" "common-lisp" :implementation))))
3105 (defvar *system-cache*
3106 ;; No good default, plus there's a security problem
3107 ;; with other users messing with such directories.
3110 (defun* output-translations ()
3111 (car *output-translations*))
3113 (defun* (setf output-translations) (new-value)
3114 (setf *output-translations*
3116 (stable-sort (copy-list new-value) #'>
3121 (let ((directory (pathname-directory (car x))))
3122 (if (listp directory) (length directory) 0))))))))
3125 (defun* output-translations-initialized-p ()
3126 (and *output-translations* t))
3128 (defun* clear-output-translations ()
3129 "Undoes any initialization of the output translations.
3130 You might want to call that before you dump an image that would be resumed
3131 with a different configuration, so the configuration would be re-read then."
3132 (setf *output-translations* '())
3135 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
3136 (values (or null pathname) &optional))
3139 (defun* resolve-relative-location-component (super x &key directory wilden)
3140 (let* ((r (etypecase x
3144 (return-from resolve-relative-location-component
3146 (resolve-relative-location-component
3147 super (car x) :directory directory :wilden wilden)
3148 (let* ((car (resolve-relative-location-component
3149 super (car x) :directory t :wilden nil))
3150 (cdr (resolve-relative-location-component
3151 (merge-pathnames* car super) (cdr x)
3152 :directory directory :wilden wilden)))
3153 (merge-pathnames* cdr car)))))
3154 ((eql :default-directory)
3155 (relativize-pathname-directory (default-directory)))
3156 ((eql :*/) *wild-directory*)
3157 ((eql :**/) *wild-inferiors*)
3158 ((eql :*.*.*) *wild-file*)
3159 ((eql :implementation) (implementation-identifier))
3160 ((eql :implementation-type) (string-downcase (implementation-type)))
3162 ((eql :uid) (princ-to-string (get-uid)))))
3163 (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
3164 (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
3165 (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
3166 (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))
3167 (merge-pathnames* s super)))
3169 (defvar *here-directory* nil
3170 "This special variable is bound to the currect directory during calls to
3171 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
3174 (defun* resolve-absolute-location-component (x &key directory wilden)
3178 (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
3180 (return-from resolve-absolute-location-component
3182 (resolve-absolute-location-component
3183 (car x) :directory directory :wilden wilden)
3184 (let* ((car (resolve-absolute-location-component
3185 (car x) :directory t :wilden nil))
3186 (cdr (resolve-relative-location-component
3187 car (cdr x) :directory directory :wilden wilden)))
3188 (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
3190 ;; special magic! we encode such paths as relative pathnames,
3191 ;; but it means "relative to the root of the source pathname's host and device".
3192 (return-from resolve-absolute-location-component
3193 (let ((p (make-pathname :directory '(:relative))))
3194 (if wilden (wilden p) p))))
3195 ((eql :home) (user-homedir))
3197 (resolve-location (or *here-directory*
3198 ;; give semantics in the case of use interactively
3200 :directory t :wilden nil))
3201 ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
3202 ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
3203 ((eql :default-directory) (default-directory))))
3204 (s (if (and wilden (not (pathnamep x)))
3207 (unless (absolute-pathname-p s)
3208 (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))
3211 (defun* resolve-location (x &key directory wilden)
3213 (resolve-absolute-location-component x :directory directory :wilden wilden)
3214 (loop :with path = (resolve-absolute-location-component
3215 (car x) :directory (and (or directory (cdr x)) t)
3216 :wilden (and wilden (null (cdr x))))
3217 :for (component . morep) :on (cdr x)
3218 :for dir = (and (or morep directory) t)
3219 :for wild = (and wilden (not morep))
3220 :do (setf path (resolve-relative-location-component
3221 path component :directory dir :wilden wild))
3222 :finally (return path))))
3224 (defun* location-designator-p (x)
3225 (flet ((absolute-component-p (c)
3226 (typep c '(or string pathname
3227 (member :root :home :here :user-cache :system-cache :default-directory))))
3228 (relative-component-p (c)
3229 (typep c '(or string pathname
3230 (member :default-directory :*/ :**/ :*.*.*
3231 :implementation :implementation-type
3232 #+asdf-unix :uid)))))
3233 (or (typep x 'boolean)
3234 (absolute-component-p x)
3235 (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
3237 (defun* location-function-p (x)
3241 (or (and (equal (first x) :function)
3242 (typep (second x) 'symbol))
3243 (and (equal (first x) 'lambda)
3245 (length=n-p (second x) 2)))))
3247 (defun* validate-output-translations-directive (directive)
3248 (or (member directive '(:enable-user-cache :disable-cache nil))
3249 (and (consp directive)
3250 (or (and (length=n-p directive 2)
3251 (or (and (eq (first directive) :include)
3252 (typep (second directive) '(or string pathname null)))
3253 (and (location-designator-p (first directive))
3254 (or (location-designator-p (second directive))
3255 (location-function-p (second directive))))))
3256 (and (length=n-p directive 1)
3257 (location-designator-p (first directive)))))))
3259 (defun* validate-output-translations-form (form &key location)
3260 (validate-configuration-form
3262 :output-translations
3263 'validate-output-translations-directive
3264 :location location :invalid-form-reporter 'invalid-output-translation))
3266 (defun* validate-output-translations-file (file)
3267 (validate-configuration-file
3268 file 'validate-output-translations-form :description "output translations"))
3270 (defun* validate-output-translations-directory (directory)
3271 (validate-configuration-directory
3272 directory :output-translations 'validate-output-translations-directive
3273 :invalid-form-reporter 'invalid-output-translation))
3275 (defun* parse-output-translations-string (string &key location)
3277 ((or (null string) (equal string ""))
3278 '(:output-translations :inherit-configuration))
3279 ((not (stringp string))
3280 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
3281 ((eql (char string 0) #\")
3282 (parse-output-translations-string (read-from-string string) :location location))
3283 ((eql (char string 0) #\()
3284 (validate-output-translations-form (read-from-string string) :location location))
3288 :with directives = ()
3290 :with end = (length string)
3292 :for i = (or (position *inter-directory-separator* string :start start) end) :do
3293 (let ((s (subseq string start i)))
3296 (push (list source (if (equal "" s) nil s)) directives)
3300 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
3303 (push :inherit-configuration directives))
3309 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
3312 (push :ignore-inherited-configuration directives))
3313 (return `(:output-translations ,@(nreverse directives)))))))))
3315 (defparameter *default-output-translations*
3316 '(environment-output-translations
3317 user-output-translations-pathname
3318 user-output-translations-directory-pathname
3319 system-output-translations-pathname
3320 system-output-translations-directory-pathname))
3322 (defun* wrapping-output-translations ()
3323 `(:output-translations
3324 ;; Some implementations have precompiled ASDF systems,
3325 ;; so we must disable translations for implementation paths.
3326 #+sbcl ,(let ((h (getenv "SBCL_HOME")))
3327 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
3328 #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
3329 #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
3330 ;; All-import, here is where we want user stuff to be:
3331 :inherit-configuration
3332 ;; These are for convenience, and can be overridden by the user:
3333 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
3334 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
3335 ;; We enable the user cache by default, and here is the place we do:
3336 :enable-user-cache))
3338 (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
3339 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
3341 (defun* user-output-translations-pathname ()
3342 (in-user-configuration-directory *output-translations-file*))
3343 (defun* system-output-translations-pathname ()
3344 (in-system-configuration-directory *output-translations-file*))
3345 (defun* user-output-translations-directory-pathname ()
3346 (in-user-configuration-directory *output-translations-directory*))
3347 (defun* system-output-translations-directory-pathname ()
3348 (in-system-configuration-directory *output-translations-directory*))
3349 (defun* environment-output-translations ()
3350 (getenv "ASDF_OUTPUT_TRANSLATIONS"))
3352 (defgeneric* process-output-translations (spec &key inherit collect))
3353 (declaim (ftype (function (t &key (:collect (or symbol function))) t)
3354 inherit-output-translations))
3355 (declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
3356 process-output-translations-directive))
3358 (defmethod process-output-translations ((x symbol) &key
3359 (inherit *default-output-translations*)
3361 (process-output-translations (funcall x) :inherit inherit :collect collect))
3362 (defmethod process-output-translations ((pathname pathname) &key inherit collect)
3364 ((directory-pathname-p pathname)
3365 (process-output-translations (validate-output-translations-directory pathname)
3366 :inherit inherit :collect collect))
3367 ((probe-file* pathname)
3368 (process-output-translations (validate-output-translations-file pathname)
3369 :inherit inherit :collect collect))
3371 (inherit-output-translations inherit :collect collect))))
3372 (defmethod process-output-translations ((string string) &key inherit collect)
3373 (process-output-translations (parse-output-translations-string string)
3374 :inherit inherit :collect collect))
3375 (defmethod process-output-translations ((x null) &key inherit collect)
3376 (declare (ignorable x))
3377 (inherit-output-translations inherit :collect collect))
3378 (defmethod process-output-translations ((form cons) &key inherit collect)
3379 (dolist (directive (cdr (validate-output-translations-form form)))
3380 (process-output-translations-directive directive :inherit inherit :collect collect)))
3382 (defun* inherit-output-translations (inherit &key collect)
3384 (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
3386 (defun* process-output-translations-directive (directive &key inherit collect)
3387 (if (atom directive)
3389 ((:enable-user-cache)
3390 (process-output-translations-directive '(t :user-cache) :collect collect))
3392 (process-output-translations-directive '(t t) :collect collect))
3393 ((:inherit-configuration)
3394 (inherit-output-translations inherit :collect collect))
3395 ((:ignore-inherited-configuration :ignore-invalid-entries nil)
3397 (let ((src (first directive))
3398 (dst (second directive)))
3399 (if (eq src :include)
3401 (process-output-translations (pathname dst) :inherit nil :collect collect))
3403 (let ((trusrc (or (eql src t)
3404 (let ((loc (resolve-location src :directory t :wilden t)))
3405 (if (absolute-pathname-p loc) (truenamize loc) loc)))))
3407 ((location-function-p dst)
3410 (if (symbolp (second dst))
3411 (fdefinition (second dst))
3412 (eval (second dst))))))
3414 (funcall collect (list trusrc t)))
3416 (let* ((trudst (make-pathname
3417 :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
3418 (wilddst (merge-pathnames* *wild-file* trudst)))
3419 (funcall collect (list wilddst t))
3420 (funcall collect (list trusrc trudst)))))))))))
3422 (defun* compute-output-translations (&optional parameter)
3423 "read the configuration, return it"
3425 (while-collecting (c)
3426 (inherit-output-translations
3427 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
3428 :test 'equal :from-end t))
3430 (defvar *output-translations-parameter* nil)
3432 (defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
3433 "read the configuration, initialize the internal configuration variable,
3434 return the configuration"
3435 (setf *output-translations-parameter* parameter
3436 (output-translations) (compute-output-translations parameter)))
3438 (defun* disable-output-translations ()
3439 "Initialize output translations in a way that maps every file to itself,
3440 effectively disabling the output translation facility."
3441 (initialize-output-translations
3442 '(:output-translations :disable-cache :ignore-inherited-configuration)))
3444 ;; checks an initial variable to see whether the state is initialized
3445 ;; or cleared. In the former case, return current configuration; in
3446 ;; the latter, initialize. ASDF will call this function at the start
3447 ;; of (asdf:find-system).
3448 (defun* ensure-output-translations ()
3449 (if (output-translations-initialized-p)
3450 (output-translations)
3451 (initialize-output-translations)))
3453 (defun* translate-pathname* (path absolute-source destination &optional root source)
3454 (declare (ignore source))
3456 ((functionp destination)
3457 (funcall destination path absolute-source))
3460 ((not (pathnamep destination))
3461 (error "Invalid destination"))
3462 ((not (absolute-pathname-p destination))
3463 (translate-pathname path absolute-source (merge-pathnames* destination root)))
3465 (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
3467 (translate-pathname path absolute-source destination))))
3469 (defun* apply-output-translations (path)
3471 #+cormanlisp (t (truenamize path))
3474 ((or pathname string)
3475 (ensure-output-translations)
3476 (loop :with p = (truenamize path)
3477 :for (source destination) :in (car *output-translations*)
3478 :for root = (when (or (eq source t)
3479 (and (pathnamep source)
3480 (not (absolute-pathname-p source))))
3482 :for absolute-source = (cond
3483 ((eq source t) (wilden root))
3484 (root (merge-pathnames* source root))
3486 :when (or (eq source t) (pathname-match-p p absolute-source))
3487 :return (translate-pathname* p absolute-source destination root source)
3488 :finally (return p)))))
3490 (defmethod output-files :around (operation component)
3491 "Translate output files, unless asked not to"
3492 (declare (ignorable operation component))
3494 (multiple-value-bind (files fixedp) (call-next-method)
3497 (mapcar #'apply-output-translations files)))
3500 (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
3502 (apply-output-translations
3503 (apply 'compile-file-pathname
3504 (truenamize (lispize-pathname input-file))
3507 (defun* tmpize-pathname (x)
3509 :name (format nil "ASDF-TMP-~A" (pathname-name x))
3512 (defun* delete-file-if-exists (x)
3513 (when (and x (probe-file* x))
3516 (defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
3517 (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
3518 (tmp-file (tmpize-pathname output-file))
3520 (multiple-value-bind (output-truename warnings-p failure-p)
3521 (apply 'compile-file input-file :output-file tmp-file keys)
3524 (setf status *compile-file-failure-behaviour*))
3526 (setf status *compile-file-warnings-behaviour*))
3528 (setf status :success)))
3530 ((:success :warn :ignore)
3531 (delete-file-if-exists output-file)
3532 (when output-truename
3533 (rename-file output-truename output-file)
3534 (setf output-truename output-file)))
3536 (delete-file-if-exists output-truename)
3537 (setf output-truename nil)))
3538 (values output-truename warnings-p failure-p))))
3541 (defun* translate-jar-pathname (source wildcard)
3542 (declare (ignore wildcard))
3543 (let* ((p (pathname (first (pathname-device source))))
3544 (root (format nil "/___jar___file___root___/~@[~A/~]"
3545 (and (find :windows *features*)
3546 (pathname-device p)))))
3547 (apply-output-translations
3549 (relativize-pathname-directory source)
3551 (relativize-pathname-directory (ensure-directory-pathname p))
3554 ;;;; -----------------------------------------------------------------
3555 ;;;; Compatibility mode for ASDF-Binary-Locations
3557 (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
3558 (declare (ignorable operation-class system args))
3559 (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
3560 (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
3561 ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
3562 which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
3563 and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
3564 In case you insist on preserving your previous A-B-L configuration, but
3565 do not know how to achieve the same effect with A-O-T, you may use function
3566 ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
3567 call that function where you would otherwise have loaded and configured A-B-L.")))
3569 (defun* enable-asdf-binary-locations-compatibility
3571 (centralize-lisp-binaries nil)
3572 (default-toplevel-directory
3573 ;; Use ".cache/common-lisp" instead ???
3574 (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
3576 (include-per-user-information nil)
3577 (map-all-source-files (or #+(or ecl clisp) t nil))
3578 (source-to-target-mappings nil))
3580 (when (null map-all-source-files)
3581 (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
3582 (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
3583 (mapped-files (if map-all-source-files *wild-file*
3584 (make-pathname :name :wild :version :wild :type fasl-type)))
3585 (destination-directory
3586 (if centralize-lisp-binaries
3587 `(,default-toplevel-directory
3588 ,@(when include-per-user-information
3589 (cdr (pathname-directory (user-homedir))))
3590 :implementation ,*wild-inferiors*)
3591 `(:root ,*wild-inferiors* :implementation))))
3592 (initialize-output-translations
3593 `(:output-translations
3594 ,@source-to-target-mappings
3595 ((:root ,*wild-inferiors* ,mapped-files)
3596 (,@destination-directory ,mapped-files))
3598 :ignore-inherited-configuration))))
3600 ;;;; -----------------------------------------------------------------
3601 ;;;; Windows shortcut support. Based on:
3603 ;;;; Jesse Hager: The Windows Shortcut File Format.
3604 ;;;; http://www.wotsit.org/list.asp?fc=13
3606 #+(and asdf-windows (not clisp))
3608 (defparameter *link-initial-dword* 76)
3609 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
3611 (defun* read-null-terminated-string (s)
3612 (with-output-to-string (out)
3613 (loop :for code = (read-byte s)
3615 :do (write-char (code-char code) out))))
3617 (defun* read-little-endian (s &optional (bytes 4))
3619 :for i :from 0 :below bytes
3620 :sum (ash (read-byte s) (* 8 i))))
3622 (defun* parse-file-location-info (s)
3623 (let ((start (file-position s))
3624 (total-length (read-little-endian s))
3625 (end-of-header (read-little-endian s))
3626 (fli-flags (read-little-endian s))
3627 (local-volume-offset (read-little-endian s))
3628 (local-offset (read-little-endian s))
3629 (network-volume-offset (read-little-endian s))
3630 (remaining-offset (read-little-endian s)))
3631 (declare (ignore total-length end-of-header local-volume-offset))
3632 (unless (zerop fli-flags)
3634 ((logbitp 0 fli-flags)
3635 (file-position s (+ start local-offset)))
3636 ((logbitp 1 fli-flags)
3637 (file-position s (+ start
3638 network-volume-offset
3640 (concatenate 'string
3641 (read-null-terminated-string s)
3643 (file-position s (+ start remaining-offset))
3644 (read-null-terminated-string s))))))
3646 (defun* parse-windows-shortcut (pathname)
3647 (with-open-file (s pathname :element-type '(unsigned-byte 8))
3649 (when (and (= (read-little-endian s) *link-initial-dword*)
3650 (let ((header (make-array (length *link-guid*))))
3651 (read-sequence header s)
3652 (equalp header *link-guid*)))
3653 (let ((flags (read-little-endian s)))
3654 (file-position s 76) ;skip rest of header
3655 (when (logbitp 0 flags)
3656 ;; skip shell item id list
3657 (let ((length (read-little-endian s 2)))
3658 (file-position s (+ length (file-position s)))))
3661 (parse-file-location-info s))
3663 (when (logbitp 2 flags)
3664 ;; skip description string
3665 (let ((length (read-little-endian s 2)))
3666 (file-position s (+ length (file-position s)))))
3667 (when (logbitp 3 flags)
3668 ;; finally, our pathname
3669 (let* ((length (read-little-endian s 2))
3670 (buffer (make-array length)))
3671 (read-sequence buffer s)
3672 (map 'string #'code-char buffer)))))))
3676 ;;;; -----------------------------------------------------------------
3677 ;;;; Source Registry Configuration, by Francois-Rene Rideau
3678 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
3680 ;; Using ack 1.2 exclusions
3681 (defvar *default-source-registry-exclusions*
3683 ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
3684 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
3685 "_sgbak" "autom4te.cache" "cover_db" "_build"
3686 "debian")) ;; debian often build stuff under the debian directory... BAD.
3688 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
3690 (defvar *source-registry* nil
3691 "Either NIL (for uninitialized), or an equal hash-table, mapping
3692 system names to pathnames of .asd files")
3694 (defun* source-registry-initialized-p ()
3695 (typep *source-registry* 'hash-table))
3697 (defun* clear-source-registry ()
3698 "Undoes any initialization of the source registry.
3699 You might want to call that before you dump an image that would be resumed
3700 with a different configuration, so the configuration would be re-read then."
3701 (setf *source-registry* nil)
3704 (defparameter *wild-asd*
3705 (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
3707 (defun directory-asd-files (directory)
3709 (directory* (merge-pathnames* *wild-asd* directory))))
3711 (defun subdirectories (directory)
3712 (let* ((directory (ensure-directory-pathname directory))
3713 #-(or cormanlisp genera xcl)
3714 (wild (merge-pathnames*
3715 #-(or abcl allegro cmu lispworks scl xcl)
3717 #+(or abcl allegro cmu lispworks scl xcl) "*.*"
3720 #-(or cormanlisp genera xcl)
3722 (directory* wild . #.(or #+clozure '(:directories t :files nil)
3723 #+mcl '(:directories t))))
3724 #+cormanlisp (cl::directory-subdirs directory)
3725 #+genera (fs:directory-list directory)
3726 #+xcl (system:list-directory directory))
3727 #+(or abcl allegro cmu genera lispworks scl xcl)
3728 (dirs (loop :for x :in dirs
3729 :for d = #+(or abcl xcl) (extensions:probe-directory x)
3730 #+allegro (excl:probe-directory x)
3731 #+(or cmu scl) (directory-pathname-p x)
3732 #+genera (getf (cdr x) :directory)
3733 #+lispworks (lw:file-directory-p x)
3734 :when d :collect #+(or abcl allegro xcl) d
3735 #+genera (ensure-directory-pathname (first x))
3736 #+(or cmu lispworks scl) x)))
3739 (defun collect-asds-in-directory (directory collect)
3740 (map () collect (directory-asd-files directory)))
3742 (defun collect-sub*directories (directory collectp recursep collector)
3743 (when (funcall collectp directory)
3744 (funcall collector directory))
3745 (dolist (subdir (subdirectories directory))
3746 (when (funcall recursep subdir)
3747 (collect-sub*directories subdir collectp recursep collector))))
3749 (defun collect-sub*directories-asd-files
3751 (exclude *default-source-registry-exclusions*)
3753 (collect-sub*directories
3756 #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
3757 #'(lambda (dir) (collect-asds-in-directory dir collect))))
3759 (defun* validate-source-registry-directive (directive)
3760 (or (member directive '(:default-registry))
3761 (and (consp directive)
3762 (let ((rest (rest directive)))
3763 (case (first directive)
3764 ((:include :directory :tree)
3765 (and (length=n-p rest 1)
3766 (location-designator-p (first rest))))
3767 ((:exclude :also-exclude)
3768 (every #'stringp rest))
3769 ((:default-registry)
3772 (defun* validate-source-registry-form (form &key location)
3773 (validate-configuration-form
3774 form :source-registry 'validate-source-registry-directive
3775 :location location :invalid-form-reporter 'invalid-source-registry))
3777 (defun* validate-source-registry-file (file)
3778 (validate-configuration-file
3779 file 'validate-source-registry-form :description "a source registry"))
3781 (defun* validate-source-registry-directory (directory)
3782 (validate-configuration-directory
3783 directory :source-registry 'validate-source-registry-directive
3784 :invalid-form-reporter 'invalid-source-registry))
3786 (defun* parse-source-registry-string (string &key location)
3788 ((or (null string) (equal string ""))
3789 '(:source-registry :inherit-configuration))
3790 ((not (stringp string))
3791 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
3792 ((find (char string 0) "\"(")
3793 (validate-source-registry-form (read-from-string string) :location location))
3797 :with directives = ()
3799 :with end = (length string)
3800 :for pos = (position *inter-directory-separator* string :start start) :do
3801 (let ((s (subseq string start (or pos end))))
3803 ((equal "" s) ; empty element: inherit
3805 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
3808 (push ':inherit-configuration directives))
3810 (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
3812 (push `(:directory ,s) directives)))
3815 (setf start (1+ pos)))
3818 (push '(:ignore-inherited-configuration) directives))
3819 (return `(:source-registry ,@(nreverse directives))))))))))
3821 (defun* register-asd-directory (directory &key recurse exclude collect)
3823 (collect-asds-in-directory directory collect)
3824 (collect-sub*directories-asd-files
3825 directory :exclude exclude :collect collect)))
3827 (defparameter *default-source-registries*
3828 '(environment-source-registry
3829 user-source-registry
3830 user-source-registry-directory
3831 system-source-registry
3832 system-source-registry-directory
3833 default-source-registry))
3835 (defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
3836 (defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
3838 (defun* wrapping-source-registry ()
3840 #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
3841 :inherit-configuration
3842 #+cmu (:tree #p"modules:")))
3843 (defun* default-source-registry ()
3844 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
3846 #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
3847 (:directory ,(default-directory))
3851 (or (getenv "XDG_DATA_HOME")
3852 (try (user-homedir) ".local/share/")))
3854 (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
3855 (dirs (cons datahome (split-string datadirs :separator ":"))))
3857 ((datahome (getenv "APPDATA"))
3859 #+lispworks (sys:get-folder-path :local-appdata)
3860 #-lispworks (try (getenv "ALLUSERSPROFILE")
3861 "Application Data"))
3862 (dirs (list datahome datadir)))
3863 #-(or asdf-unix asdf-windows)
3865 (loop :for dir :in dirs
3866 :collect `(:directory ,(try dir "common-lisp/systems/"))
3867 :collect `(:tree ,(try dir "common-lisp/source/"))))
3868 :inherit-configuration)))
3869 (defun* user-source-registry ()
3870 (in-user-configuration-directory *source-registry-file*))
3871 (defun* system-source-registry ()
3872 (in-system-configuration-directory *source-registry-file*))
3873 (defun* user-source-registry-directory ()
3874 (in-user-configuration-directory *source-registry-directory*))
3875 (defun* system-source-registry-directory ()
3876 (in-system-configuration-directory *source-registry-directory*))
3877 (defun* environment-source-registry ()
3878 (getenv "CL_SOURCE_REGISTRY"))
3880 (defgeneric* process-source-registry (spec &key inherit register))
3881 (declaim (ftype (function (t &key (:register (or symbol function))) t)
3882 inherit-source-registry))
3883 (declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
3884 process-source-registry-directive))
3886 (defmethod process-source-registry ((x symbol) &key inherit register)
3887 (process-source-registry (funcall x) :inherit inherit :register register))
3888 (defmethod process-source-registry ((pathname pathname) &key inherit register)
3890 ((directory-pathname-p pathname)
3891 (let ((*here-directory* (truenamize pathname)))
3892 (process-source-registry (validate-source-registry-directory pathname)
3893 :inherit inherit :register register)))
3894 ((probe-file* pathname)
3895 (let ((*here-directory* (pathname-directory-pathname pathname)))
3896 (process-source-registry (validate-source-registry-file pathname)
3897 :inherit inherit :register register)))
3899 (inherit-source-registry inherit :register register))))
3900 (defmethod process-source-registry ((string string) &key inherit register)
3901 (process-source-registry (parse-source-registry-string string)
3902 :inherit inherit :register register))
3903 (defmethod process-source-registry ((x null) &key inherit register)
3904 (declare (ignorable x))
3905 (inherit-source-registry inherit :register register))
3906 (defmethod process-source-registry ((form cons) &key inherit register)
3907 (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
3908 (dolist (directive (cdr (validate-source-registry-form form)))
3909 (process-source-registry-directive directive :inherit inherit :register register))))
3911 (defun* inherit-source-registry (inherit &key register)
3913 (process-source-registry (first inherit) :register register :inherit (rest inherit))))
3915 (defun* process-source-registry-directive (directive &key inherit register)
3916 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
3919 (destructuring-bind (pathname) rest
3920 (process-source-registry (resolve-location pathname) :inherit nil :register register)))
3922 (destructuring-bind (pathname) rest
3924 (funcall register (resolve-location pathname :directory t)))))
3926 (destructuring-bind (pathname) rest
3928 (funcall register (resolve-location pathname :directory t)
3929 :recurse t :exclude *source-registry-exclusions*))))
3931 (setf *source-registry-exclusions* rest))
3933 (appendf *source-registry-exclusions* rest))
3934 ((:default-registry)
3935 (inherit-source-registry '(default-source-registry) :register register))
3936 ((:inherit-configuration)
3937 (inherit-source-registry inherit :register register))
3938 ((:ignore-inherited-configuration)
3942 (defun* flatten-source-registry (&optional parameter)
3944 (while-collecting (collect)
3945 (let ((*default-pathname-defaults* (default-directory)))
3946 (inherit-source-registry
3947 `(wrapping-source-registry
3949 ,@*default-source-registries*)
3950 :register #'(lambda (directory &key recurse exclude)
3951 (collect (list directory :recurse recurse :exclude exclude)))))
3952 :test 'equal :from-end t)))
3954 ;; Will read the configuration and initialize all internal variables,
3955 ;; and return the new configuration.
3956 (defun* compute-source-registry (&optional parameter (registry *source-registry*))
3957 (dolist (entry (flatten-source-registry parameter))
3958 (destructuring-bind (directory &key recurse exclude) entry
3959 (let* ((h (make-hash-table :test 'equal)))
3960 (register-asd-directory
3961 directory :recurse recurse :exclude exclude :collect
3963 (let ((name (pathname-name asd)))
3965 ((gethash name registry) ; already shadowed by something else
3967 ((gethash name h) ; conflict at current level
3968 (when *asdf-verbose*
3969 (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
3970 found several entries for ~A - picking ~S over ~S~:>")
3971 directory recurse name (gethash name h) asd)))
3973 (setf (gethash name registry) asd)
3974 (setf (gethash name h) asd))))))
3978 (defvar *source-registry-parameter* nil)
3980 (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
3981 (setf *source-registry-parameter* parameter)
3982 (setf *source-registry* (make-hash-table :test 'equal))
3983 (compute-source-registry parameter))
3985 ;; Checks an initial variable to see whether the state is initialized
3986 ;; or cleared. In the former case, return current configuration; in
3987 ;; the latter, initialize. ASDF will call this function at the start
3988 ;; of (asdf:find-system) to make sure the source registry is initialized.
3989 ;; However, it will do so *without* a parameter, at which point it
3990 ;; will be too late to provide a parameter to this function, though
3991 ;; you may override the configuration explicitly by calling
3992 ;; initialize-source-registry directly with your parameter.
3993 (defun* ensure-source-registry (&optional parameter)
3994 (unless (source-registry-initialized-p)
3995 (initialize-source-registry parameter))
3998 (defun* sysdef-source-registry-search (system)
3999 (ensure-source-registry)
4000 (values (gethash (coerce-name system) *source-registry*)))
4002 (defun* clear-configuration ()
4003 (clear-source-registry)
4004 (clear-output-translations))
4007 ;;; ECL support for COMPILE-OP / LOAD-OP
4009 ;;; In ECL, these operations produce both FASL files and the
4010 ;;; object files that they are built from. Having both of them allows
4011 ;;; us to later on reuse the object files for bundles, libraries,
4012 ;;; standalone executables, etc.
4014 ;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
4015 ;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
4019 (setf *compile-op-compile-file-function*
4020 (lambda (input-file &rest keys &key output-file &allow-other-keys)
4021 (declare (ignore output-file))
4022 (multiple-value-bind (object-file flags1 flags2)
4023 (apply 'compile-file* input-file :system-p t keys)
4024 (values (and object-file
4025 (c::build-fasl (compile-file-pathname object-file :type :fasl)
4026 :lisp-files (list object-file))
4031 (defmethod output-files ((operation compile-op) (c cl-source-file))
4032 (declare (ignorable operation))
4033 (let ((p (lispize-pathname (component-pathname c))))
4034 (list (compile-file-pathname p :type :object)
4035 (compile-file-pathname p :type :fasl))))
4037 (defmethod perform ((o load-op) (c cl-source-file))
4039 (loop :for i :in (input-files o c)
4040 :unless (string= (pathname-type i) "fas")
4041 :collect (compile-file-pathname (lispize-pathname i))))))
4043 ;;;; -----------------------------------------------------------------
4044 ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
4046 (defvar *require-asdf-operator* 'load-op)
4048 (defun* module-provide-asdf (name)
4050 ((style-warning #'muffle-warning)
4051 (missing-component (constantly nil))
4052 (error #'(lambda (e)
4053 (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
4055 (let ((*verbose-out* (make-broadcast-stream))
4056 (system (find-system (string-downcase name) nil)))
4058 (operate *require-asdf-operator* system :verbose nil)
4061 #+(or abcl clisp clozure cmu ecl sbcl)
4062 (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
4064 (eval `(pushnew 'module-provide-asdf
4065 #+abcl sys::*module-provider-functions*
4067 #+clozure ccl:*module-provider-functions*
4068 #+cmu ext:*module-provider-functions*
4069 #+ecl si:*module-provider-functions*
4070 #+sbcl sb-ext:*module-provider-functions*))))
4073 ;;;; -------------------------------------------------------------------------
4074 ;;;; Cleanups after hot-upgrade.
4075 ;;;; Things to do in case we're upgrading from a previous version of ASDF.
4076 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
4079 ;;; If a previous version of ASDF failed to read some configuration, try again.
4080 (when *ignored-configuration-form*
4081 (clear-configuration)
4082 (setf *ignored-configuration-form* nil))
4084 ;;;; -----------------------------------------------------------------
4086 (when *load-verbose*
4087 (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
4090 (eval-when (:compile-toplevel :execute)
4091 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
4092 (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
4094 (pushnew :asdf *features*)
4095 (pushnew :asdf2 *features*)
4099 ;;; Local Variables: