1 ;;; -*- mode: common-lisp; package: asdf; -*-
2 ;;; This is ASDF: 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 HEAD
14 ;;; is the latest development version, whereas the revision tagged
15 ;;; RELEASE 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-2010 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.
51 (defpackage :asdf-bootstrap (:use :cl))
52 (in-package :asdf-bootstrap)
54 ;; Implementation-dependent tweaks
55 (eval-when (:compile-toplevel :load-toplevel :execute)
56 ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
58 (setf excl::*autoload-package-name-alist*
59 (remove "asdf" excl::*autoload-package-name-alist*
60 :test 'equalp :key 'car))
63 (eval-when (:compile-toplevel :load-toplevel)
64 (defpackage :asdf-utilities (:use :cl))
65 (defpackage :asdf (:use :cl :asdf-utilities))))
67 ;;;; Create packages in a way that is compatible with hot-upgrade.
68 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
69 ;;;; See more at the end of the file.
71 (eval-when (:load-toplevel :compile-toplevel :execute)
72 (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
73 (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105.
74 (existing-asdf (find-package :asdf))
75 (vername '#:*asdf-version*)
76 (versym (and existing-asdf
77 (find-symbol (string vername) existing-asdf)))
78 (existing-version (and versym (boundp versym) (symbol-value versym)))
79 (already-there (equal asdf-version existing-version)))
80 (unless (and existing-asdf already-there)
83 (format *trace-output*
84 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
85 existing-version asdf-version))
87 ((rename-away (package)
88 (loop :with name = (package-name package)
89 :for i :from 1 :for new = (format nil "~A.~D" name i)
90 :unless (find-package new) :do
91 (rename-package-name package name new)))
92 (rename-package-name (package old new)
93 (let* ((old-names (cons (package-name package)
94 (package-nicknames package)))
95 (new-names (subst new old old-names :test 'equal))
96 (new-name (car new-names))
97 (new-nicknames (cdr new-names)))
98 (rename-package package new-name new-nicknames)))
99 (ensure-exists (name nicknames use)
104 (mapcar #'find-package (cons name nicknames)))
108 ;; do away with packages with conflicting (nick)names
109 (map () #'rename-away (cdr previous))
110 ;; reuse previous package with same name
111 (let ((p (car previous)))
112 (rename-package p name nicknames)
116 (make-package name :nicknames nicknames :use use)))))
117 (find-sym (symbol package)
118 (find-symbol (string symbol) package))
119 (intern* (symbol package)
120 (intern (string symbol) package))
121 (remove-symbol (symbol package)
122 (let ((sym (find-sym symbol package)))
124 (unexport sym package)
125 (unintern sym package))))
126 (ensure-unintern (package symbols)
127 (dolist (sym symbols) (remove-symbol sym package)))
128 (ensure-shadow (package symbols)
129 (shadow symbols package))
130 (ensure-use (package use)
131 (dolist (used (reverse use))
132 (do-external-symbols (sym used)
133 (unless (eq sym (find-sym sym package))
134 (remove-symbol sym package)))
135 (use-package used package)))
136 (ensure-fmakunbound (package symbols)
137 (loop :for name :in symbols
138 :for sym = (find-sym name package)
139 :when sym :do (fmakunbound sym)))
140 (ensure-export (package export)
141 (let ((syms (loop :for x :in export :collect
142 (intern* x package))))
143 (do-external-symbols (sym package)
144 (unless (member sym syms)
145 (remove-symbol sym package)))
147 (export sym package))))
148 (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
149 (let ((p (ensure-exists name nicknames use)))
150 (ensure-unintern p unintern)
151 (ensure-shadow p shadow)
152 (ensure-export p export)
153 (ensure-fmakunbound p fmakunbound)
156 ((pkgdcl (name &key nicknames use export
157 redefined-functions unintern fmakunbound shadow)
159 ',name :nicknames ',nicknames :use ',use :export ',export
161 :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
162 :fmakunbound ',(append fmakunbound))))
165 :nicknames (#:asdf-extensions)
167 :unintern (#:split #:make-collector)
169 (#:absolute-pathname-p
174 #:directory-pathname-p
176 #:ensure-directory-pathname
181 #:pathname-directory-pathname
187 #:component-name-to-pathname-components
189 #:system-registered-p
194 :use (:common-lisp :asdf-utilities)
196 (#:perform #:explain #:output-files #:operation-done-p
197 #:perform-with-restarts #:component-relative-pathname
198 #:system-source-file #:operate #:find-component)
200 (#:*asdf-revision* #:around #:asdf-method-combination
201 #:split #:make-collector)
203 (#:system-source-file
204 #:component-relative-pathname #:system-relative-pathname
205 #:process-source-registry
206 #:inherit-source-registry #:process-source-registry-directive)
208 (#:defsystem #:oos #:operate #:find-system #:run-shell-command
209 #:system-definition-pathname #:find-component ; miscellaneous
210 #:compile-system #:load-system #:test-system
211 #:compile-op #:load-op #:load-source-op
213 #:operation ; operations
214 #:feature ; sort-of operation
215 #:version ; metaphorically sort-of an operation
218 #:input-files #:output-files #:perform ; operation methods
219 #:operation-done-p #:explain
221 #:component #:source-file
222 #:c-source-file #:cl-source-file #:java-source-file
228 #:module ; components
232 #:module-components ; component accessors
233 #:module-components-by-name ; component accessors
235 #:component-relative-pathname
242 #:component-depends-on
245 #:system-long-description
251 #:system-source-directory
252 #:system-relative-pathname
255 #:operation-on-warnings
256 #:operation-on-failure
257 ;;#:*component-parent-pathname*
258 #:*system-definition-search-functions*
259 #:*central-registry* ; variables
260 #:*compile-file-warnings-behaviour*
261 #:*compile-file-failure-behaviour*
267 #:operation-error #:compile-failed #:compile-warned #:compile-error
270 #:load-system-definition-error
271 #:error-component #:error-operation
272 #:system-definition-error
274 #:missing-component-of-version
276 #:missing-dependency-of-version
277 #:circular-dependency ; errors
283 #:coerce-entry-to-directory
284 #:remove-entry-from-registry
286 #:initialize-output-translations
287 #:disable-output-translations
288 #:clear-output-translations
289 #:ensure-output-translations
290 #:apply-output-translations
292 #:compile-file-pathname*
293 #:enable-asdf-binary-locations-compatibility
295 #:*default-source-registries*
296 #:initialize-source-registry
297 #:compute-source-registry
298 #:clear-source-registry
299 #:ensure-source-registry
300 #:process-source-registry)))
301 (let* ((version (intern* vername :asdf))
302 (upvar (intern* '#:*upgraded-p* :asdf))
303 (upval0 (and (boundp upvar) (symbol-value upvar)))
304 (upval1 (if existing-version (cons existing-version upval0) upval0)))
306 (defparameter ,version ,asdf-version)
307 (defparameter ,upvar ',upval1))))))))
311 ;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
313 (eval-when (:compile-toplevel :load-toplevel)
314 (defvar *asdf-version* nil)
315 (defvar *upgraded-p* nil))
318 (when (find-class 'compile-op nil)
319 (defmethod update-instance-for-redefined-class :after
320 ((c compile-op) added deleted plist &key)
321 (declare (ignore added deleted))
322 (let ((system-p (getf plist 'system-p)))
323 (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
324 (when (find-class 'module nil)
326 '(defmethod update-instance-for-redefined-class :after
327 ((m module) added deleted plist &key)
328 (declare (ignorable deleted plist))
329 (format *trace-output* "Updating ~A~%" m)
330 (when (member 'components-by-name added)
331 (compute-module-components-by-name m))))))
333 ;;;; -------------------------------------------------------------------------
334 ;;;; User-visible parameters
336 (defun asdf-version ()
337 "Exported interface to the version of ASDF currently installed. A string.
338 You can compare this string with e.g.:
339 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
342 (defvar *resolve-symlinks* t
343 "Determine whether or not ASDF resolves symlinks when defining systems.
347 (defvar *compile-file-warnings-behaviour* :warn
348 "How should ASDF react if it encounters a warning when compiling a
349 file? Valid values are :error, :warn, and :ignore.")
351 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn
352 "How should ASDF react if it encounters a failure \(per the
353 ANSI spec of COMPILE-FILE\) when compiling a file? Valid values are
354 :error, :warn, and :ignore. Note that ASDF ALWAYS raises an error
355 if it fails to create an output file when compiling.")
357 (defvar *verbose-out* nil)
359 (defvar *asdf-verbose* t)
361 (defparameter +asdf-methods+
362 '(perform-with-restarts perform explain output-files operation-done-p))
365 (eval-when (:compile-toplevel :execute)
366 (defparameter *acl-warn-save*
367 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
368 excl:*warn-on-nested-reader-conditionals*))
369 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
370 (setf excl:*warn-on-nested-reader-conditionals* nil)))
372 ;;;; -------------------------------------------------------------------------
373 ;;;; ASDF Interface, in terms of generic functions.
374 (defmacro defgeneric* (name formals &rest options)
376 #+(or gcl ecl) (fmakunbound ',name)
377 (defgeneric ,name ,formals ,@options)))
379 (defgeneric* perform-with-restarts (operation component))
380 (defgeneric* perform (operation component))
381 (defgeneric* operation-done-p (operation component))
382 (defgeneric* explain (operation component))
383 (defgeneric* output-files (operation component))
384 (defgeneric* input-files (operation component))
385 (defgeneric component-operation-time (operation component))
387 (defgeneric* system-source-file (system)
388 (:documentation "Return the source file in which system is defined."))
390 (defgeneric component-system (component)
391 (:documentation "Find the top-level system containing COMPONENT"))
393 (defgeneric component-pathname (component)
394 (:documentation "Extracts the pathname applicable for a particular component."))
396 (defgeneric component-relative-pathname (component)
397 (:documentation "Returns a pathname for the component argument intended to be
398 interpreted relative to the pathname of that component's parent.
399 Despite the function's name, the return value may be an absolute
400 pathname, because an absolute pathname may be interpreted relative to
401 another pathname in a degenerate way."))
403 (defgeneric component-property (component property))
405 (defgeneric (setf component-property) (new-value component property))
407 (defgeneric version-satisfies (component version))
409 (defgeneric* find-component (base path)
410 (:documentation "Finds the component with PATH starting from BASE module;
411 if BASE is nil, then the component is assumed to be a system."))
413 (defgeneric source-file-type (component system))
415 (defgeneric operation-ancestor (operation)
417 "Recursively chase the operation's parent pointer until we get to
418 the head of the tree"))
420 (defgeneric component-visited-p (operation component)
421 (:documentation "Returns the value stored by a call to
422 VISIT-COMPONENT, if that has been called, otherwise NIL.
423 This value stored will be a cons cell, the first element
424 of which is a computed key, so not interesting. The
425 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
426 it as (cdr (component-visited-p op c)).
427 In the current form of ASDF, the DATA value retrieved is
428 effectively a boolean, indicating whether some operations are
429 to be performed in order to do OPERATION X COMPONENT. If the
430 data value is NIL, the combination had been explored, but no
431 operations needed to be performed."))
433 (defgeneric visit-component (operation component data)
434 (:documentation "Record DATA as being associated with OPERATION
435 and COMPONENT. This is a side-effecting function: the association
436 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
438 No evidence that DATA is ever interesting, beyond just being
439 non-NIL. Using the data field is probably very risky; if there is
440 already a record for OPERATION X COMPONENT, DATA will be quietly
441 discarded instead of recorded."))
443 (defgeneric (setf visiting-component) (new-value operation component))
445 (defgeneric component-visiting-p (operation component))
447 (defgeneric component-depends-on (operation component)
449 "Returns a list of dependencies needed by the component to perform
450 the operation. A dependency has one of the following forms:
452 (<operation> <component>*), where <operation> is a class
453 designator and each <component> is a component
454 designator, which means that the component depends on
455 <operation> having been performed on each <component>; or
457 (FEATURE <feature>), which means that the component depends
458 on <feature>'s presence in *FEATURES*.
460 Methods specialized on subclasses of existing component types
461 should usually append the results of CALL-NEXT-METHOD to the
464 (defgeneric component-self-dependencies (operation component))
466 (defgeneric traverse (operation component)
468 "Generate and return a plan for performing OPERATION on COMPONENT.
470 The plan returned is a list of dotted-pairs. Each pair is the CONS
471 of ASDF operation object and a COMPONENT object. The pairs will be
472 processed in order by OPERATE."))
475 ;;;; -------------------------------------------------------------------------
476 ;;;; General Purpose Utilities
478 (defmacro while-collecting ((&rest collectors) &body body)
479 "COLLECTORS should be a list of names for collections. A collector
480 defines a function that, when applied to an argument inside BODY, will
481 add its argument to the corresponding collection. Returns multiple values,
482 a list for each collection, in order.
484 \(while-collecting \(foo bar\)
485 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
487 \(bar \(second x\)\)\)\)
488 Returns two values: \(A B C\) and \(1 2 3\)."
489 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
490 (initial-values (mapcar (constantly nil) collectors)))
491 `(let ,(mapcar #'list vars initial-values)
492 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
494 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
496 (defmacro aif (test then &optional else)
497 `(let ((it ,test)) (if it ,then ,else)))
499 (defun pathname-directory-pathname (pathname)
500 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
501 and NIL NAME, TYPE and VERSION components"
503 (make-pathname :name nil :type nil :version nil :defaults pathname)))
505 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
506 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
507 does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
508 Also, if either argument is NIL, then the other argument is returned unmodified."
509 (when (null specified) (return-from merge-pathnames* defaults))
510 (when (null defaults) (return-from merge-pathnames* specified))
511 (let* ((specified (pathname specified))
512 (defaults (pathname defaults))
513 (directory (pathname-directory specified))
514 #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
515 (name (or (pathname-name specified) (pathname-name defaults)))
516 (type (or (pathname-type specified) (pathname-type defaults)))
517 (version (or (pathname-version specified) (pathname-version defaults))))
518 (labels ((ununspecific (x)
519 (if (eq x :unspecific) nil x))
520 (unspecific-handler (p)
521 (if (typep p 'logical-pathname) #'ununspecific #'identity)))
522 (multiple-value-bind (host device directory unspecific-handler)
523 (#-gcl ecase #+gcl case (first directory)
525 (values (pathname-host defaults)
526 (pathname-device defaults)
527 (pathname-directory defaults)
528 (unspecific-handler defaults)))
530 (values (pathname-host specified)
531 (pathname-device specified)
533 (unspecific-handler specified)))
535 (values (pathname-host defaults)
536 (pathname-device defaults)
537 (if (pathname-directory defaults)
538 (append (pathname-directory defaults) (cdr directory))
540 (unspecific-handler defaults)))
543 (assert (stringp (first directory)))
544 (values (pathname-host defaults)
545 (pathname-device defaults)
546 (append (pathname-directory defaults) directory)
547 (unspecific-handler defaults))))
548 (make-pathname :host host :device device :directory directory
549 :name (funcall unspecific-handler name)
550 :type (funcall unspecific-handler type)
551 :version (funcall unspecific-handler version))))))
553 (define-modify-macro appendf (&rest args)
554 append "Append onto list") ;; only to be used on short lists.
556 (define-modify-macro orf (&rest args)
559 (defun first-char (s)
560 (and (stringp s) (plusp (length s)) (char s 0)))
563 (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
565 (defun asdf-message (format-string &rest format-args)
566 (declare (dynamic-extent format-args))
567 (apply #'format *verbose-out* format-string format-args))
569 (defun split-string (string &key max (separator '(#\Space #\Tab)))
570 "Split STRING into a list of components separated by
571 any of the characters in the sequence SEPARATOR.
572 If MAX is specified, then no more than max(1,MAX) components will be returned,
573 starting the separation from the end, e.g. when called with arguments
574 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
576 (let ((list nil) (words 0) (end (length string)))
577 (flet ((separatorp (char) (find char separator))
578 (done () (return (cons (subseq string 0 end) list))))
580 :for start = (if (and max (>= words (1- max)))
582 (position-if #'separatorp string :end end :from-end t)) :do
585 (push (subseq string (1+ start) end) list)
587 (setf end start))))))
589 (defun split-name-type (filename)
591 ;; Giving :unspecific as argument to make-pathname is not portable.
592 ;; See CLHS make-pathname and 19.2.2.2.3.
593 ;; We only use it on implementations that support it.
594 (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
595 (destructuring-bind (name &optional (type unspecific))
596 (split-string filename :max 2 :separator ".")
598 (values filename unspecific)
599 (values name type)))))
601 (defun component-name-to-pathname-components (s &optional force-directory)
602 "Splits the path string S, returning three values:
603 A flag that is either :absolute or :relative, indicating
604 how the rest of the values are to be interpreted.
605 A directory path --- a list of strings, suitable for
606 use with MAKE-PATHNAME when prepended with the flag
608 A filename with type extension, possibly NIL in the
609 case of a directory pathname.
610 FORCE-DIRECTORY forces S to be interpreted as a directory
611 pathname \(third return value will be NIL, final component
612 of S will be treated as part of the directory path.
614 The intention of this function is to support structured component names,
615 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
617 (check-type s string)
618 (let* ((components (split-string s :separator "/"))
619 (last-comp (car (last components))))
620 (multiple-value-bind (relative components)
621 (if (equal (first components) "")
622 (if (equal (first-char s) #\/)
623 (values :absolute (cdr components))
624 (values :relative nil))
625 (values :relative components))
626 (setf components (remove "" components :test #'equal))
628 ((equal last-comp "")
629 (values relative components nil)) ; "" already removed
631 (values relative components nil))
633 (values relative (butlast components) last-comp))))))
635 (defun remove-keys (key-names args)
636 (loop :for (name val) :on args :by #'cddr
637 :unless (member (symbol-name name) key-names
638 :key #'symbol-name :test 'equal)
639 :append (list name val)))
641 (defun remove-keyword (key args)
642 (loop :for (k v) :on args :by #'cddr
650 (sb-ext:posix-getenv x)
656 (cdr (assoc (intern x :keyword) ext:*environment-list*))
658 (lispworks:environment-variable x)
666 (defun directory-pathname-p (pathname)
667 "Does PATHNAME represent a directory?
669 A directory-pathname is a pathname _without_ a filename. The three
670 ways that the filename components can be missing are for it to be NIL,
671 :UNSPECIFIC or the empty string.
673 Note that this does _not_ check to see that PATHNAME points to an
674 actually-existing directory."
675 (flet ((check-one (x)
676 (member x '(nil :unspecific "") :test 'equal)))
677 (and (check-one (pathname-name pathname))
678 (check-one (pathname-type pathname))
681 (defun ensure-directory-pathname (pathspec)
682 "Converts the non-wild pathname designator PATHSPEC to directory form."
685 (ensure-directory-pathname (pathname pathspec)))
686 ((not (pathnamep pathspec))
687 (error "Invalid pathname designator ~S" pathspec))
688 ((wild-pathname-p pathspec)
689 (error "Can't reliably convert wild pathnames."))
690 ((directory-pathname-p pathspec)
693 (make-pathname :directory (append (or (pathname-directory pathspec)
695 (list (file-namestring pathspec)))
696 :name nil :type nil :version nil
697 :defaults pathspec))))
699 (defun absolute-pathname-p (pathspec)
700 (eq :absolute (car (pathname-directory (pathname pathspec)))))
702 (defun length=n-p (x n) ;is it that (= (length x) n) ?
703 (check-type n (integer 0 *))
705 :for l = x :then (cdr l)
706 :for i :downfrom n :do
708 ((zerop i) (return (null l)))
709 ((not (consp l)) (return nil)))))
711 (defun ends-with (s suffix)
712 (check-type s string)
713 (check-type suffix string)
714 (let ((start (- (length s) (length suffix))))
716 (string-equal s suffix :start1 start))))
718 (defun read-file-forms (file)
719 (with-open-file (in file)
720 (loop :with eof = (list nil)
721 :for form = (read in nil eof)
725 #-(and (or win32 windows mswindows mingw32) (not cygwin))
727 #+clisp (defun get-uid () (posix:uid))
728 #+sbcl (defun get-uid () (sb-unix:unix-getuid))
729 #+cmu (defun get-uid () (unix:unix-getuid))
730 #+ecl (ffi:clines "#include <sys/types.h>" "#include <unistd.h>")
731 #+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t))
732 #+allegro (defun get-uid () (excl.osi:getuid))
733 #-(or cmu sbcl clisp allegro ecl)
736 (with-output-to-string (*verbose-out*)
737 (run-shell-command "id -ur"))))
738 (with-input-from-string (stream uid-string)
740 (handler-case (parse-integer (read-line stream))
741 (error () (error "Unable to find out user ID")))))))
743 (defun pathname-root (pathname)
744 (make-pathname :host (pathname-host pathname)
745 :device (pathname-device pathname)
746 :directory '(:absolute)
747 :name nil :type nil :version nil))
749 (defun truenamize (p)
750 "Resolve as much of a pathname as possible"
752 (when (typep p 'logical-pathname) (return p))
753 (let* ((p (merge-pathnames* p))
754 (directory (pathname-directory p)))
755 (when (typep p 'logical-pathname) (return p))
756 (ignore-errors (return (truename p)))
757 #-sbcl (when (stringp directory) (return p))
758 (when (not (eq :absolute (car directory))) (return p))
759 (let ((sofar (ignore-errors (truename (pathname-root p)))))
760 (unless sofar (return p))
761 (flet ((solution (directories)
763 (make-pathname :host nil :device nil
764 :directory `(:relative ,@directories)
765 :name (pathname-name p)
766 :type (pathname-type p)
767 :version (pathname-version p))
769 (loop :for component :in (cdr directory)
770 :for rest :on (cdr directory)
771 :for more = (ignore-errors
774 (make-pathname :directory `(:relative ,component))
778 (return (solution rest)))
780 (return (solution nil))))))))
782 (defun resolve-symlinks (path)
783 #-allegro (truenamize path)
784 #+allegro (excl:pathname-resolve-symbolic-links path))
786 (defun default-directory ()
787 (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
789 (defun lispize-pathname (input-file)
790 (make-pathname :type "lisp" :defaults input-file))
792 (defparameter *wild-path*
793 (make-pathname :directory '(:relative :wild-inferiors)
794 :name :wild :type :wild :version :wild))
797 (merge-pathnames* *wild-path* path))
799 (defun directorize-pathname-host-device (pathname)
800 (let* ((root (pathname-root pathname))
801 (wild-root (wilden root))
802 (absolute-pathname (merge-pathnames* pathname root))
803 (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
804 (separator (last-char (namestring foo)))
805 (root-namestring (namestring root))
808 (lambda (x) (or (eql x #\:)
811 (multiple-value-bind (relative path filename)
812 (component-name-to-pathname-components root-string t)
813 (declare (ignore relative filename))
815 (make-pathname :defaults root
816 :directory `(:absolute ,@path))))
817 (translate-pathname absolute-pathname wild-root (wilden new-base))))))
819 ;;;; -------------------------------------------------------------------------
820 ;;;; Classes, Conditions
822 (define-condition system-definition-error (error) ()
823 ;; [this use of :report should be redundant, but unfortunately it's not.
824 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
825 ;; over print-object; this is always conditions::%print-condition for
826 ;; condition objects, which in turn does inheritance of :report options at
827 ;; run-time. fortunately, inheritance means we only need this kludge here in
828 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
829 #+cmu (:report print-object))
831 (declaim (ftype (function (t) t)
832 format-arguments format-control
833 error-name error-pathname error-condition
835 error-component error-operation
836 module-components module-components-by-name)
837 (ftype (function (t t) t) (setf module-components-by-name)))
840 (define-condition formatted-system-definition-error (system-definition-error)
841 ((format-control :initarg :format-control :reader format-control)
842 (format-arguments :initarg :format-arguments :reader format-arguments))
843 (:report (lambda (c s)
844 (apply #'format s (format-control c) (format-arguments c)))))
846 (define-condition load-system-definition-error (system-definition-error)
847 ((name :initarg :name :reader error-name)
848 (pathname :initarg :pathname :reader error-pathname)
849 (condition :initarg :condition :reader error-condition))
850 (:report (lambda (c s)
851 (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
852 (error-name c) (error-pathname c) (error-condition c)))))
854 (define-condition circular-dependency (system-definition-error)
855 ((components :initarg :components :reader circular-dependency-components)))
857 (define-condition duplicate-names (system-definition-error)
858 ((name :initarg :name :reader duplicate-names-name))
859 (:report (lambda (c s)
860 (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
861 (duplicate-names-name c)))))
863 (define-condition missing-component (system-definition-error)
864 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
865 (parent :initform nil :reader missing-parent :initarg :parent)))
867 (define-condition missing-component-of-version (missing-component)
868 ((version :initform nil :reader missing-version :initarg :version)))
870 (define-condition missing-dependency (missing-component)
871 ((required-by :initarg :required-by :reader missing-required-by)))
873 (define-condition missing-dependency-of-version (missing-dependency
874 missing-component-of-version)
877 (define-condition operation-error (error)
878 ((component :reader error-component :initarg :component)
879 (operation :reader error-operation :initarg :operation))
880 (:report (lambda (c s)
881 (format s "~@<erred while invoking ~A on ~A~@:>"
882 (error-operation c) (error-component c)))))
883 (define-condition compile-error (operation-error) ())
884 (define-condition compile-failed (compile-error) ())
885 (define-condition compile-warned (compile-error) ())
887 (defclass component ()
888 ((name :accessor component-name :initarg :name :documentation
889 "Component name: designator for a string composed of portable pathname characters")
890 (version :accessor component-version :initarg :version)
891 (in-order-to :initform nil :initarg :in-order-to
892 :accessor component-in-order-to)
893 ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
894 (load-dependencies :accessor component-load-dependencies :initform nil)
895 ;; XXX crap name, but it's an official API name!
896 (do-first :initform nil :initarg :do-first
897 :accessor component-do-first)
898 ;; methods defined using the "inline" style inside a defsystem form:
899 ;; need to store them somewhere so we can delete them when the system
901 (inline-methods :accessor component-inline-methods :initform nil)
902 (parent :initarg :parent :initform nil :reader component-parent)
903 ;; no direct accessor for pathname, we do this as a method to allow
904 ;; it to default in funky ways if not supplied
905 (relative-pathname :initarg :pathname)
907 (operation-times :initform (make-hash-table)
908 :accessor component-operation-times)
909 ;; XXX we should provide some atomic interface for updating the
910 ;; component properties
911 (properties :accessor component-properties :initarg :properties
914 (defun component-find-path (component)
916 (loop :for c = component :then (component-parent c)
917 :while c :collect (component-name c))))
919 (defmethod print-object ((c component) stream)
920 (print-unreadable-object (c stream :type t :identity nil)
921 (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
924 ;;;; methods: conditions
926 (defmethod print-object ((c missing-dependency) s)
927 (format s "~@<~A, required by ~A~@:>"
928 (call-next-method c nil) (missing-required-by c)))
930 (defun sysdef-error (format &rest arguments)
931 (error 'formatted-system-definition-error :format-control
932 format :format-arguments arguments))
934 ;;;; methods: components
936 (defmethod print-object ((c missing-component) s)
937 (format s "~@<component ~S not found~
940 (when (missing-parent c)
941 (component-name (missing-parent c)))))
943 (defmethod print-object ((c missing-component-of-version) s)
944 (format s "~@<component ~S does not match version ~A~
948 (when (missing-parent c)
949 (component-name (missing-parent c)))))
951 (defmethod component-system ((component component))
952 (aif (component-parent component)
953 (component-system it)
956 (defvar *default-component-class* 'cl-source-file)
958 (defun compute-module-components-by-name (module)
959 (let ((hash (make-hash-table :test 'equal)))
960 (setf (module-components-by-name module) hash)
961 (loop :for c :in (module-components module)
962 :for name = (component-name c)
963 :for previous = (gethash name (module-components-by-name module))
966 (error 'duplicate-names :name name))
967 :do (setf (gethash name (module-components-by-name module)) c))
970 (defclass module (component)
974 :accessor module-components)
976 :accessor module-components-by-name)
977 ;; What to do if we can't satisfy a dependency of one of this module's
978 ;; components. This allows a limited form of conditional processing.
979 (if-component-dep-fails
981 :initarg :if-component-dep-fails
982 :accessor module-if-component-dep-fails)
983 (default-component-class
984 :initform *default-component-class*
985 :initarg :default-component-class
986 :accessor module-default-component-class)))
988 (defun component-parent-pathname (component)
989 ;; No default anymore (in particular, no *default-pathname-defaults*).
990 ;; If you force component to have a NULL pathname, you better arrange
991 ;; for any of its children to explicitly provide a proper absolute pathname
992 ;; wherever a pathname is actually wanted.
993 (let ((parent (component-parent component)))
995 (component-pathname parent))))
997 (defmethod component-pathname ((component component))
998 (if (slot-boundp component 'absolute-pathname)
999 (slot-value component 'absolute-pathname)
1002 (component-relative-pathname component)
1003 (pathname-directory-pathname (component-parent-pathname component)))))
1004 (unless (or (null pathname) (absolute-pathname-p pathname))
1005 (error "Invalid relative pathname ~S for component ~S" pathname component))
1006 (setf (slot-value component 'absolute-pathname) pathname)
1009 (defmethod component-property ((c component) property)
1010 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
1012 (defmethod (setf component-property) (new-value (c component) property)
1013 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
1015 (setf (cdr a) new-value)
1016 (setf (slot-value c 'properties)
1017 (acons property new-value (slot-value c 'properties)))))
1020 (defclass system (module)
1021 ((description :accessor system-description :initarg :description)
1023 :accessor system-long-description :initarg :long-description)
1024 (author :accessor system-author :initarg :author)
1025 (maintainer :accessor system-maintainer :initarg :maintainer)
1026 (licence :accessor system-licence :initarg :licence
1027 :accessor system-license :initarg :license)
1028 (source-file :reader system-source-file :initarg :source-file
1029 :writer %set-system-source-file)))
1031 ;;;; -------------------------------------------------------------------------
1032 ;;;; version-satisfies
1034 (defmethod version-satisfies ((c component) version)
1035 (unless (and version (slot-boundp c 'version))
1036 (return-from version-satisfies t))
1037 (version-satisfies (component-version c) version))
1039 (defmethod version-satisfies ((cver string) version)
1040 (let ((x (mapcar #'parse-integer
1041 (split-string cver :separator ".")))
1042 (y (mapcar #'parse-integer
1043 (split-string version :separator "."))))
1044 (labels ((bigger (x y)
1047 ((> (car x) (car y)) t)
1048 ((= (car x) (car y))
1049 (bigger (cdr x) (cdr y))))))
1050 (and (= (car x) (car y))
1051 (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
1053 ;;;; -------------------------------------------------------------------------
1054 ;;;; Finding systems
1056 (defun make-defined-systems-table ()
1057 (make-hash-table :test 'equal))
1059 (defvar *defined-systems* (make-defined-systems-table)
1060 "This is a hash table whose keys are strings, being the
1061 names of the systems, and whose values are pairs, the first
1062 element of which is a universal-time indicating when the
1063 system definition was last updated, and the second element
1064 of which is a system object.")
1066 (defun coerce-name (name)
1068 (component (component-name name))
1069 (symbol (string-downcase (symbol-name name)))
1071 (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
1073 (defun system-registered-p (name)
1074 (gethash (coerce-name name) *defined-systems*))
1076 (defun map-systems (fn)
1077 "Apply FN to each defined system.
1079 FN should be a function of one argument. It will be
1080 called with an object of type asdf:system."
1081 (maphash (lambda (_ datum)
1082 (declare (ignore _))
1083 (destructuring-bind (_ . def) datum
1084 (declare (ignore _))
1088 ;;; for the sake of keeping things reasonably neat, we adopt a
1089 ;;; convention that functions in this list are prefixed SYSDEF-
1091 (defparameter *system-definition-search-functions*
1092 '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
1094 (defun system-definition-pathname (system)
1095 (let ((system-name (coerce-name system)))
1097 (some (lambda (x) (funcall x system-name))
1098 *system-definition-search-functions*)
1099 (let ((system-pair (system-registered-p system-name)))
1101 (system-source-file (cdr system-pair)))))))
1103 (defvar *central-registry* nil
1104 "A list of 'system directory designators' ASDF uses to find systems.
1106 A 'system directory designator' is a pathname or an expression
1107 which evaluates to a pathname. For example:
1109 (setf asdf:*central-registry*
1110 (list '*default-pathname-defaults*
1111 #p\"/home/me/cl/systems/\"
1112 #p\"/usr/share/common-lisp/systems/\"))
1114 This is for backward compatibilily.
1115 Going forward, we recommend new users should be using the source-registry.
1118 (defun probe-asd (name defaults)
1120 (when (directory-pathname-p defaults)
1123 :defaults defaults :version :newest :case :local
1126 (when (probe-file file)
1128 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
1131 :defaults defaults :version :newest :case :local
1132 :name (concatenate 'string name ".asd")
1134 (when (probe-file shortcut)
1135 (let ((target (parse-windows-shortcut shortcut)))
1137 (return (pathname target)))))))))
1139 (defun sysdef-central-registry-search (system)
1140 (let ((name (coerce-name system))
1145 (dolist (dir *central-registry*)
1146 (let ((defaults (eval dir)))
1148 (cond ((directory-pathname-p defaults)
1149 (let ((file (probe-asd name defaults)))
1154 (let* ((*print-circle* nil)
1157 "~@<While searching for system ~S: ~S evaluated ~
1158 to ~S which is not a directory.~@:>"
1159 system dir defaults)))
1161 (remove-entry-from-registry ()
1162 :report "Remove entry from *central-registry* and continue"
1163 (push dir to-remove))
1164 (coerce-entry-to-directory ()
1166 (format s "Coerce entry to ~a, replace ~a and continue."
1167 (ensure-directory-pathname defaults) dir))
1168 (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
1170 (dolist (dir to-remove)
1171 (setf *central-registry* (remove dir *central-registry*)))
1172 (dolist (pair to-replace)
1173 (let* ((current (car pair))
1175 (position (position current *central-registry*)))
1176 (setf *central-registry*
1177 (append (subseq *central-registry* 0 position)
1179 (subseq *central-registry* (1+ position))))))))))
1181 (defun make-temporary-package ()
1182 (flet ((try (counter)
1184 (make-package (format nil "~A~D" :asdf counter)
1185 :use '(:cl :asdf)))))
1186 (do* ((counter 0 (+ counter 1))
1187 (package (try counter) (try counter)))
1188 (package package))))
1190 (defun safe-file-write-date (pathname)
1191 ;; If FILE-WRITE-DATE returns NIL, it's possible that
1192 ;; the user or some other agent has deleted an input file.
1193 ;; Also, generated files will not exist at the time planning is done
1194 ;; and calls operation-done-p which calls safe-file-write-date.
1195 ;; So it is very possible that we can't get a valid file-write-date,
1196 ;; and we can survive and we will continue the planning
1197 ;; as if the file were very old.
1198 ;; (or should we treat the case in a different, special way?)
1199 (or (and pathname (probe-file pathname) (file-write-date pathname))
1202 (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
1206 (defun find-system (name &optional (error-p t))
1208 (let* ((name (coerce-name name))
1209 (in-memory (system-registered-p name))
1210 (on-disk (system-definition-pathname name)))
1213 (< (car in-memory) (safe-file-write-date on-disk))))
1214 (let ((package (make-temporary-package)))
1217 ((error (lambda (condition)
1218 (error 'load-system-definition-error
1219 :name name :pathname on-disk
1220 :condition condition))))
1221 (let ((*package* package))
1223 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
1226 (delete-package package))))
1227 (let ((in-memory (system-registered-p name)))
1229 (progn (when on-disk (setf (car in-memory)
1230 (safe-file-write-date on-disk)))
1232 (when error-p (error 'missing-component :requires name)))))))
1234 (defun register-system (name system)
1235 (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
1236 (setf (gethash (coerce-name name) *defined-systems*)
1237 (cons (get-universal-time) system)))
1239 (defun sysdef-find-asdf (system)
1240 (let ((name (coerce-name system)))
1241 (when (equal name "asdf")
1242 (let* ((registered (cdr (gethash name *defined-systems*)))
1243 (asdf (or registered
1245 'system :name "asdf"
1246 :source-file (or *compile-file-truename* *load-truename*)))))
1248 (register-system "asdf" asdf))
1249 (throw 'find-system asdf)))))
1252 ;;;; -------------------------------------------------------------------------
1253 ;;;; Finding components
1255 (defmethod find-component ((base string) path)
1256 (let ((s (find-system base nil)))
1257 (and s (find-component s path))))
1259 (defmethod find-component ((base symbol) path)
1261 (base (find-component (coerce-name base) path))
1262 (path (find-component path nil))
1265 (defmethod find-component ((base cons) path)
1266 (find-component (car base) (cons (cdr base) path)))
1268 (defmethod find-component ((module module) (name string))
1269 (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
1270 (compute-module-components-by-name module))
1271 (values (gethash name (module-components-by-name module))))
1273 (defmethod find-component ((component component) (name symbol))
1275 (find-component component (coerce-name name))
1278 (defmethod find-component ((module module) (name cons))
1279 (find-component (find-component module (car name)) (cdr name)))
1282 ;;; component subclasses
1284 (defclass source-file (component)
1285 ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
1287 (defclass cl-source-file (source-file)
1288 ((type :initform "lisp")))
1289 (defclass c-source-file (source-file)
1290 ((type :initform "c")))
1291 (defclass java-source-file (source-file)
1292 ((type :initform "java")))
1293 (defclass static-file (source-file) ())
1294 (defclass doc-file (static-file) ())
1295 (defclass html-file (doc-file)
1296 ((type :initform "html")))
1298 (defmethod source-file-type ((component module) (s module))
1299 (declare (ignorable component s))
1301 (defmethod source-file-type ((component source-file) (s module))
1302 (declare (ignorable s))
1303 (source-file-explicit-type component))
1305 (defun merge-component-name-type (name &key type defaults)
1306 ;; The defaults are required notably because they provide the default host
1307 ;; to the below make-pathname, which may crucially matter to people using
1308 ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
1309 ;; NOTE that the host and device slots will be taken from the defaults,
1310 ;; but that should only matter if you either (a) use absolute pathnames, or
1311 ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
1312 ;; ASDF-UTILITIES:MERGE-PATHNAMES*
1317 (merge-component-name-type (string-downcase name) :type type :defaults defaults))
1319 (multiple-value-bind (relative path filename)
1320 (component-name-to-pathname-components name (eq type :directory))
1321 (multiple-value-bind (name type)
1323 ((or (eq type :directory) (null filename))
1326 (values filename type))
1328 (split-name-type filename)))
1329 (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
1330 (host (pathname-host defaults))
1331 (device (pathname-device defaults)))
1332 (make-pathname :directory `(,relative ,@path)
1333 :name name :type type
1334 :host host :device device)))))))
1336 (defmethod component-relative-pathname ((component component))
1337 (merge-component-name-type
1338 (or (slot-value component 'relative-pathname)
1339 (component-name component))
1340 :type (source-file-type component (component-system component))
1341 :defaults (component-parent-pathname component)))
1343 ;;;; -------------------------------------------------------------------------
1346 ;;; one of these is instantiated whenever #'operate is called
1348 (defclass operation ()
1350 ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
1351 ;; T to force the inside of existing system,
1352 ;; but not recurse to other systems we depend on.
1353 ;; :ALL (or any other atom) to force all systems
1354 ;; including other systems we depend on.
1355 ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
1356 ;; to force systems named in a given list
1357 ;; (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
1358 (forced :initform nil :initarg :force :accessor operation-forced)
1359 (original-initargs :initform nil :initarg :original-initargs
1360 :accessor operation-original-initargs)
1361 (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
1362 (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
1363 (parent :initform nil :initarg :parent :accessor operation-parent)))
1365 (defmethod print-object ((o operation) stream)
1366 (print-unreadable-object (o stream :type t :identity t)
1368 (prin1 (operation-original-initargs o) stream))))
1370 (defmethod shared-initialize :after ((operation operation) slot-names
1373 (declare (ignorable operation slot-names force))
1374 ;; empty method to disable initarg validity checking
1377 (defun node-for (o c)
1378 (cons (class-name (class-of o)) c))
1380 (defmethod operation-ancestor ((operation operation))
1381 (aif (operation-parent operation)
1382 (operation-ancestor it)
1386 (defun make-sub-operation (c o dep-c dep-o)
1387 "C is a component, O is an operation, DEP-C is another
1388 component, and DEP-O, confusingly enough, is an operation
1389 class specifier, not an operation."
1390 (let* ((args (copy-list (operation-original-initargs o)))
1391 (force-p (getf args :force)))
1392 ;; note explicit comparison with T: any other non-NIL force value
1393 ;; (e.g. :recursive) will pass through
1394 (cond ((and (null (component-parent c))
1395 (null (component-parent dep-c))
1396 (not (eql c dep-c)))
1397 (when (eql force-p t)
1398 (setf (getf args :force) nil))
1399 (apply #'make-instance dep-o
1401 :original-initargs args args))
1402 ((subtypep (type-of o) dep-o)
1405 (apply #'make-instance dep-o
1406 :parent o :original-initargs args args)))))
1409 (defmethod visit-component ((o operation) (c component) data)
1410 (unless (component-visited-p o c)
1411 (setf (gethash (node-for o c)
1412 (operation-visited-nodes (operation-ancestor o)))
1415 (defmethod component-visited-p ((o operation) (c component))
1416 (gethash (node-for o c)
1417 (operation-visited-nodes (operation-ancestor o))))
1419 (defmethod (setf visiting-component) (new-value operation component)
1420 ;; MCL complains about unused lexical variables
1421 (declare (ignorable operation component))
1424 (defmethod (setf visiting-component) (new-value (o operation) (c component))
1425 (let ((node (node-for o c))
1426 (a (operation-ancestor o)))
1428 (setf (gethash node (operation-visiting-nodes a)) t)
1429 (remhash node (operation-visiting-nodes a)))
1432 (defmethod component-visiting-p ((o operation) (c component))
1433 (let ((node (node-for o c)))
1434 (gethash node (operation-visiting-nodes (operation-ancestor o)))))
1436 (defmethod component-depends-on ((op-spec symbol) (c component))
1437 (component-depends-on (make-instance op-spec) c))
1439 (defmethod component-depends-on ((o operation) (c component))
1440 (cdr (assoc (class-name (class-of o))
1441 (component-in-order-to c))))
1443 (defmethod component-self-dependencies ((o operation) (c component))
1444 (let ((all-deps (component-depends-on o c)))
1445 (remove-if-not (lambda (x)
1446 (member (component-name c) (cdr x) :test #'string=))
1449 (defmethod input-files ((operation operation) (c component))
1450 (let ((parent (component-parent c))
1451 (self-deps (component-self-dependencies operation c)))
1453 (mapcan (lambda (dep)
1454 (destructuring-bind (op name) dep
1455 (output-files (make-instance op)
1456 (find-component parent name))))
1458 ;; no previous operations needed? I guess we work with the
1459 ;; original source file, then
1460 (list (component-pathname c)))))
1462 (defmethod input-files ((operation operation) (c module))
1463 (declare (ignorable operation c))
1466 (defmethod component-operation-time (o c)
1467 (gethash (type-of o) (component-operation-times c)))
1469 (defmethod operation-done-p ((o operation) (c component))
1470 (let ((out-files (output-files o c))
1471 (in-files (input-files o c))
1472 (op-time (component-operation-time o c)))
1473 (flet ((earliest-out ()
1474 (reduce #'min (mapcar #'safe-file-write-date out-files)))
1476 (reduce #'max (mapcar #'safe-file-write-date in-files))))
1478 ((and (not in-files) (not out-files))
1479 ;; arbitrary decision: an operation that uses nothing to
1480 ;; produce nothing probably isn't doing much.
1481 ;; e.g. operations on systems, modules that have no immediate action,
1482 ;; but are only meaningful through traversed dependencies
1485 ;; an operation without output-files is probably meant
1486 ;; for its side-effects in the current image,
1487 ;; assumed to be idem-potent,
1488 ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
1489 (and op-time (>= op-time (latest-in))))
1491 ;; an operation without output-files and no input-files
1492 ;; is probably meant for its side-effects on the file-system,
1493 ;; assumed to have to be done everytime.
1494 ;; (I don't think there is any such case in ASDF unless extended)
1497 ;; an operation with both input and output files is assumed
1498 ;; as computing the latter from the former,
1499 ;; assumed to have been done if the latter are all older
1501 ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
1502 ;; We use >= instead of > to play nice with generated files.
1503 ;; This opens a race condition if an input file is changed
1504 ;; after the output is created but within the same second
1505 ;; of filesystem time; but the same race condition exists
1506 ;; whenever the computation from input to output takes more
1507 ;; than one second of filesystem time (or just crosses the
1508 ;; second). So that's cool.
1510 (every #'probe-file in-files)
1511 (every #'probe-file out-files)
1512 (>= (earliest-out) (latest-in))))))))
1516 ;;; For 1.700 I've done my best to refactor TRAVERSE
1517 ;;; by splitting it up in a bunch of functions,
1518 ;;; so as to improve the collection and use-detection algorithm. --fare
1519 ;;; The protocol is as follows: we pass around operation, dependency,
1520 ;;; bunch of other stuff, and a force argument. Return a force flag.
1521 ;;; The returned flag is T if anything has changed that requires a rebuild.
1522 ;;; The force argument is a list of components that will require a rebuild
1523 ;;; if the flag is T, at which point whoever returns the flag has to
1524 ;;; mark them all as forced, and whoever recurses again can use a NIL list
1525 ;;; as a further argument.
1527 (defvar *forcing* nil
1528 "This dynamically-bound variable is used to force operations in
1529 recursive calls to traverse.")
1531 (defgeneric do-traverse (operation component collect))
1533 (defun %do-one-dep (operation c collect required-op required-c required-v)
1534 ;; collects a partial plan that results from performing required-op
1535 ;; on required-c, possibly with a required-vERSION
1536 (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
1537 (and d (version-satisfies d required-v) d))
1539 (error 'missing-dependency-of-version
1542 :requires required-c)
1543 (error 'missing-dependency
1545 :requires required-c))))
1546 (op (make-sub-operation c operation dep-c required-op)))
1547 (do-traverse op dep-c collect)))
1549 (defun do-one-dep (operation c collect required-op required-c required-v)
1550 ;; this function is a thin, error-handling wrapper around
1551 ;; %do-one-dep. Returns a partial plan per that function.
1554 (return (%do-one-dep operation c collect
1555 required-op required-c required-v))
1558 (format s "~@<Retry loading component ~S.~@:>"
1563 (print (list :c1 c (typep c 'missing-dependency)))
1564 (when (typep c 'missing-dependency)
1565 (print (list :c2 (missing-requires c) required-c
1566 (equalp (missing-requires c)
1570 (and (typep c 'missing-dependency)
1571 (equalp (missing-requires c)
1574 (defun do-dep (operation c collect op dep)
1575 ;; type of arguments uncertain:
1576 ;; op seems to at least potentially be a symbol, rather than an operation
1577 ;; dep is a list of component names
1578 (cond ((eq op 'feature)
1579 (if (member (car dep) *features*)
1581 (error 'missing-dependency
1583 :requires (car dep))))
1586 (flet ((dep (op comp ver)
1587 (when (do-one-dep operation c collect
1593 ;; structured dependencies --- this parses keywords
1594 ;; the keywords could be broken out and cleanly (extensibly)
1595 ;; processed by EQL methods
1596 (cond ((eq :version (first d))
1597 ;; https://bugs.launchpad.net/asdf/+bug/527788
1598 (dep op (second d) (third d)))
1599 ;; This particular subform is not documented and
1600 ;; has always been broken in the past.
1601 ;; Therefore no one uses it, and I'm cerroring it out,
1603 ;; See https://bugs.launchpad.net/asdf/+bug/518467
1604 ((eq :feature (first d))
1605 (cerror "Continue nonetheless."
1606 "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
1607 (when (find (second d) *features* :test 'string-equal)
1608 (dep op (third d) nil)))
1610 (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
1613 (defun do-collect (collect x)
1614 (funcall collect x))
1616 (defmethod do-traverse ((operation operation) (c component) collect)
1617 (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
1623 (update-flag (do-dep operation c collect op comp))))
1624 ;; Have we been visited yet? If so, just process the result.
1625 (aif (component-visited-p operation c)
1627 (update-flag (cdr it))
1628 (return-from do-traverse flag)))
1630 (when (component-visiting-p operation c)
1631 (error 'circular-dependency :components (list c)))
1632 (setf (visiting-component operation c) t)
1635 ;; first we check and do all the dependencies for the module.
1636 ;; Operations planned in this loop will show up
1637 ;; in the results, and are consumed below.
1638 (let ((*forcing* nil))
1639 ;; upstream dependencies are never forced to happen just because
1640 ;; the things that depend on them are....
1642 :for (required-op . deps) :in (component-depends-on operation c)
1643 :do (dep required-op deps)))
1646 (when (typep c 'module)
1647 (let ((at-least-one nil)
1648 ;; This is set based on the results of the
1649 ;; dependencies and whether we are in the
1650 ;; context of a *forcing* call...
1651 ;; inter-system dependencies do NOT trigger
1652 ;; building components
1655 (and flag (not (typep c 'system)))))
1657 (while-collecting (internal-collect)
1658 (dolist (kid (module-components c))
1661 (do-traverse operation kid #'internal-collect))
1662 (missing-dependency (condition)
1663 (when (eq (module-if-component-dep-fails c)
1666 (setf error condition))
1668 (declare (ignore c))
1669 (setf at-least-one t))))
1670 (when (and (eq (module-if-component-dep-fails c)
1677 (not (operation-done-p operation c))
1678 ;; For sub-operations, check whether
1679 ;; the original ancestor operation was forced,
1680 ;; or names us amongst an explicit list of things to force...
1681 ;; except that this check doesn't distinguish
1682 ;; between all the things with a given name. Sigh.
1684 (let ((f (operation-forced
1685 (operation-ancestor operation))))
1686 (and f (or (not (consp f)) ;; T or :ALL
1687 (and (typep c 'system) ;; list of names of systems to force
1688 (member (component-name c) f
1689 :test #'string=)))))))
1691 (let ((do-first (cdr (assoc (class-name (class-of operation))
1692 (component-do-first c)))))
1693 (loop :for (required-op . deps) :in do-first
1694 :do (do-dep operation c collect required-op deps)))
1695 (do-collect collect (vector module-ops))
1696 (do-collect collect (cons operation c)))))
1697 (setf (visiting-component operation c) nil)))
1698 (visit-component operation c flag)
1701 (defun flatten-tree (l)
1702 ;; You collected things into a list.
1703 ;; Most elements are just things to collect again.
1704 ;; A (simple-vector 1) indicate that you should recurse into its contents.
1705 ;; This way, in two passes (rather than N being the depth of the tree),
1706 ;; you can collect things with marginally constant-time append,
1707 ;; achieving linear time collection instead of quadratic time.
1708 (while-collecting (c)
1710 (if (typep x '(simple-vector 1))
1714 (dolist (x l) (r x))))
1717 (defmethod traverse ((operation operation) (c component))
1718 ;; cerror'ing a feature that seems to have NEVER EVER worked
1719 ;; ever since danb created it in his 2003-03-16 commit e0d02781.
1720 ;; It was both fixed and disabled in the 1.700 rewrite.
1721 (when (consp (operation-forced operation))
1722 (cerror "Continue nonetheless."
1723 "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
1724 (setf (operation-forced operation)
1725 (mapcar #'coerce-name (operation-forced operation))))
1727 (while-collecting (collect)
1728 (do-traverse operation c #'collect))))
1730 (defmethod perform ((operation operation) (c source-file))
1732 "~@<required method PERFORM not implemented ~
1733 for operation ~A, component ~A~@:>"
1734 (class-of operation) (class-of c)))
1736 (defmethod perform ((operation operation) (c module))
1737 (declare (ignorable operation c))
1740 (defmethod explain ((operation operation) (component component))
1741 (asdf-message "~&;;; ~A on ~A~%" operation component))
1743 ;;;; -------------------------------------------------------------------------
1746 (defclass compile-op (operation)
1747 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
1748 (on-warnings :initarg :on-warnings :accessor operation-on-warnings
1749 :initform *compile-file-warnings-behaviour*)
1750 (on-failure :initarg :on-failure :accessor operation-on-failure
1751 :initform *compile-file-failure-behaviour*)
1752 (flags :initarg :flags :accessor compile-op-flags
1753 :initform #-ecl nil #+ecl '(:system-p t))))
1755 (defmethod perform :before ((operation compile-op) (c source-file))
1756 (map nil #'ensure-directories-exist (output-files operation c)))
1759 (defmethod perform :after ((o compile-op) (c cl-source-file))
1760 ;; Note how we use OUTPUT-FILES to find the binary locations
1761 ;; This allows the user to override the names.
1762 (let* ((files (output-files o c))
1763 (object (first files))
1764 (fasl (second files)))
1765 (c:build-fasl fasl :lisp-files (list object))))
1767 (defmethod perform :after ((operation operation) (c component))
1768 (setf (gethash (type-of operation) (component-operation-times c))
1769 (get-universal-time)))
1771 (declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
1775 ;;; perform is required to check output-files to find out where to put
1776 ;;; its answers, in case it has been overridden for site policy
1777 (defmethod perform ((operation compile-op) (c cl-source-file))
1778 #-:broken-fasl-loader
1779 (let ((source-file (component-pathname c))
1780 (output-file (car (output-files operation c)))
1781 (*compile-file-warnings-behaviour* (operation-on-warnings operation))
1782 (*compile-file-failure-behaviour* (operation-on-failure operation)))
1783 (multiple-value-bind (output warnings-p failure-p)
1784 (apply #'compile-file* source-file :output-file output-file
1785 (compile-op-flags operation))
1787 (case (operation-on-warnings operation)
1789 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
1791 (:error (error 'compile-warned :component c :operation operation))
1794 (case (operation-on-failure operation)
1796 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
1798 (:error (error 'compile-failed :component c :operation operation))
1801 (error 'compile-error :component c :operation operation)))))
1803 (defmethod output-files ((operation compile-op) (c cl-source-file))
1804 (declare (ignorable operation))
1805 (let ((p (lispize-pathname (component-pathname c))))
1806 #-:broken-fasl-loader
1807 (list (compile-file-pathname p #+ecl :type #+ecl :object)
1808 #+ecl (compile-file-pathname p :type :fasl))
1809 #+:broken-fasl-loader (list p)))
1811 (defmethod perform ((operation compile-op) (c static-file))
1812 (declare (ignorable operation c))
1815 (defmethod output-files ((operation compile-op) (c static-file))
1816 (declare (ignorable operation c))
1819 (defmethod input-files ((operation compile-op) (c static-file))
1820 (declare (ignorable operation c))
1824 ;;;; -------------------------------------------------------------------------
1827 (defclass basic-load-op (operation) ())
1829 (defclass load-op (basic-load-op) ())
1831 (defmethod perform ((o load-op) (c cl-source-file))
1832 #-ecl (mapcar #'load (input-files o c))
1833 #+ecl (loop :for i :in (input-files o c)
1834 :unless (string= (pathname-type i) "fas")
1835 :collect (let ((output (compile-file-pathname (lispize-pathname i))))
1838 (defmethod perform-with-restarts (operation component)
1839 (perform operation component))
1841 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
1842 (declare (ignorable o))
1843 (loop :with state = :initial
1844 :until (or (eq state :success)
1845 (eq state :failure)) :do
1848 (setf state :failure)
1850 (setf state :success))
1852 (setf state :recompiled)
1853 (perform (make-instance 'compile-op) c))
1855 (with-simple-restart
1856 (try-recompiling "Recompile ~a and try loading it again"
1858 (setf state :failed-load)
1860 (setf state :success))))))
1862 (defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
1863 (loop :with state = :initial
1864 :until (or (eq state :success)
1865 (eq state :failure)) :do
1868 (setf state :failure)
1870 (setf state :success))
1872 (setf state :recompiled)
1873 (perform-with-restarts o c))
1875 (with-simple-restart
1876 (try-recompiling "Try recompiling ~a"
1878 (setf state :failed-compile)
1880 (setf state :success))))))
1882 (defmethod perform ((operation load-op) (c static-file))
1883 (declare (ignorable operation c))
1886 (defmethod operation-done-p ((operation load-op) (c static-file))
1887 (declare (ignorable operation c))
1890 (defmethod output-files ((operation operation) (c component))
1891 (declare (ignorable operation c))
1894 (defmethod component-depends-on ((operation load-op) (c component))
1895 (declare (ignorable operation))
1896 (cons (list 'compile-op (component-name c))
1897 (call-next-method)))
1899 ;;;; -------------------------------------------------------------------------
1902 (defclass load-source-op (basic-load-op) ())
1904 (defmethod perform ((o load-source-op) (c cl-source-file))
1905 (declare (ignorable o))
1906 (let ((source (component-pathname c)))
1907 (setf (component-property c 'last-loaded-as-source)
1909 (get-universal-time)))))
1911 (defmethod perform ((operation load-source-op) (c static-file))
1912 (declare (ignorable operation c))
1915 (defmethod output-files ((operation load-source-op) (c component))
1916 (declare (ignorable operation c))
1919 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
1920 (defmethod component-depends-on ((o load-source-op) (c component))
1921 (declare (ignorable o))
1922 (let ((what-would-load-op-do (cdr (assoc 'load-op
1923 (component-in-order-to c)))))
1924 (mapcar (lambda (dep)
1925 (if (eq (car dep) 'load-op)
1926 (cons 'load-source-op (cdr dep))
1928 what-would-load-op-do)))
1930 (defmethod operation-done-p ((o load-source-op) (c source-file))
1931 (declare (ignorable o))
1932 (if (or (not (component-property c 'last-loaded-as-source))
1933 (> (safe-file-write-date (component-pathname c))
1934 (component-property c 'last-loaded-as-source)))
1938 ;;;; -------------------------------------------------------------------------
1941 (defclass test-op (operation) ())
1943 (defmethod perform ((operation test-op) (c component))
1944 (declare (ignorable operation c))
1947 (defmethod operation-done-p ((operation test-op) (c system))
1948 "Testing a system is _never_ done."
1949 (declare (ignorable operation c))
1952 (defmethod component-depends-on :around ((o test-op) (c system))
1953 (declare (ignorable o))
1954 (cons `(load-op ,(component-name c)) (call-next-method)))
1957 ;;;; -------------------------------------------------------------------------
1958 ;;;; Invoking Operations
1960 (defgeneric* operate (operation-class system &key &allow-other-keys))
1962 (defmethod operate (operation-class system &rest args
1963 &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
1965 (declare (ignore force))
1966 (let* ((*package* *package*)
1967 (*readtable* *readtable*)
1968 (op (apply #'make-instance operation-class
1969 :original-initargs args
1971 (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
1972 (system (if (typep system 'component) system (find-system system))))
1973 (unless (version-satisfies system version)
1974 (error 'missing-component-of-version :requires system :version version))
1975 (let ((steps (traverse op system)))
1976 (with-compilation-unit ()
1977 (loop :for (op . component) :in steps :do
1981 (perform-with-restarts op component)
1986 (format s "~@<Retry performing ~S on ~S.~@:>"
1991 (format s "~@<Continue, treating ~S on ~S as ~
1992 having been successful.~@:>"
1994 (setf (gethash (type-of op)
1995 (component-operation-times component))
1996 (get-universal-time))
2000 (defun oos (operation-class system &rest args &key force verbose version
2002 (declare (ignore force verbose version))
2003 (apply #'operate operation-class system args))
2005 (let ((operate-docstring
2006 "Operate does three things:
2008 1. It creates an instance of OPERATION-CLASS using any keyword parameters
2010 2. It finds the asdf-system specified by SYSTEM (possibly loading
2012 3. It then calls TRAVERSE with the operation and system as arguments
2014 The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
2015 handling code. If a VERSION argument is supplied, then operate also
2016 ensures that the system found satisfies it using the VERSION-SATISFIES
2019 Note that dependencies may cause the operation to invoke other
2020 operations on the system or its components: the new operations will be
2021 created with the same initargs as the original one.
2023 (setf (documentation 'oos 'function)
2025 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
2027 (setf (documentation 'operate 'function)
2030 (defun load-system (system &rest args &key force verbose version
2032 "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
2034 (declare (ignore force verbose version))
2035 (apply #'operate 'load-op system args))
2037 (defun compile-system (system &rest args &key force verbose version
2039 "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
2041 (declare (ignore force verbose version))
2042 (apply #'operate 'compile-op system args))
2044 (defun test-system (system &rest args &key force verbose version
2046 "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
2048 (declare (ignore force verbose version))
2049 (apply #'operate 'test-op system args))
2051 ;;;; -------------------------------------------------------------------------
2054 (defun load-pathname ()
2055 (let ((pn (or *load-pathname* *compile-file-pathname*)))
2056 (if *resolve-symlinks*
2057 (and pn (resolve-symlinks pn))
2060 (defun determine-system-pathname (pathname pathname-supplied-p)
2061 ;; The defsystem macro calls us to determine
2062 ;; the pathname of a system as follows:
2063 ;; 1. the one supplied,
2064 ;; 2. derived from *load-pathname* via load-pathname
2065 ;; 3. taken from the *default-pathname-defaults* via default-directory
2066 (let* ((file-pathname (load-pathname))
2067 (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
2068 (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
2070 (default-directory))))
2072 (defmacro defsystem (name &body options)
2073 (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
2074 defsystem-depends-on &allow-other-keys)
2076 (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
2078 ;; system must be registered before we parse the body, otherwise
2079 ;; we recur when trying to find an existing system of the same name
2080 ;; to reuse options (e.g. pathname) from
2081 ,@(loop :for system :in defsystem-depends-on
2082 :collect `(load-system ,system))
2083 (let ((s (system-registered-p ',name)))
2084 (cond ((and s (eq (type-of (cdr s)) ',class))
2085 (setf (car s) (get-universal-time)))
2087 (change-class (cdr s) ',class))
2089 (register-system (quote ,name)
2090 (make-instance ',class :name ',name))))
2091 (%set-system-source-file (load-pathname)
2092 (cdr (system-registered-p ',name))))
2093 (parse-component-form
2095 :module (coerce-name ',name)
2097 ,(determine-system-pathname pathname pathname-arg-p)
2098 ',component-options))))))
2100 (defun class-for-type (parent type)
2101 (or (loop :for symbol :in (list
2102 (unless (keywordp type) type)
2103 (find-symbol (symbol-name type) *package*)
2104 (find-symbol (symbol-name type) :asdf))
2105 :for class = (and symbol (find-class symbol nil))
2106 :when (and class (subtypep class 'component))
2108 (and (eq type :file)
2109 (or (module-default-component-class parent)
2110 (find-class *default-component-class*)))
2111 (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
2113 (defun maybe-add-tree (tree op1 op2 c)
2114 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
2115 Returns the new tree (which probably shares structure with the old one)"
2116 (let ((first-op-tree (assoc op1 tree)))
2119 (aif (assoc op2 (cdr first-op-tree))
2120 (if (find c (cdr it))
2122 (setf (cdr it) (cons c (cdr it))))
2123 (setf (cdr first-op-tree)
2124 (acons op2 (list c) (cdr first-op-tree))))
2126 (acons op1 (list (list op2 c)) tree))))
2128 (defun union-of-dependencies (&rest deps)
2129 (let ((new-tree nil))
2131 (dolist (op-tree dep)
2132 (dolist (op (cdr op-tree))
2133 (dolist (c (cdr op))
2135 (maybe-add-tree new-tree (car op-tree) (car op) c))))))
2139 (defvar *serial-depends-on* nil)
2141 (defun sysdef-error-component (msg type name value)
2142 (sysdef-error (concatenate 'string msg
2143 "~&The value specified for ~(~A~) ~A is ~S")
2146 (defun check-component-input (type name weakly-depends-on
2147 depends-on components in-order-to)
2148 "A partial test of the values of a component."
2149 (unless (listp depends-on)
2150 (sysdef-error-component ":depends-on must be a list."
2151 type name depends-on))
2152 (unless (listp weakly-depends-on)
2153 (sysdef-error-component ":weakly-depends-on must be a list."
2154 type name weakly-depends-on))
2155 (unless (listp components)
2156 (sysdef-error-component ":components must be NIL or a list of components."
2157 type name components))
2158 (unless (and (listp in-order-to) (listp (car in-order-to)))
2159 (sysdef-error-component ":in-order-to must be NIL or a list of components."
2160 type name in-order-to)))
2162 (defun %remove-component-inline-methods (component)
2163 (dolist (name +asdf-methods+)
2165 ;; this is inefficient as most of the stored
2166 ;; methods will not be for this particular gf
2167 ;; But this is hardly performance-critical
2169 (remove-method (symbol-function name) m))
2170 (component-inline-methods component)))
2171 ;; clear methods, then add the new ones
2172 (setf (component-inline-methods component) nil))
2174 (defun %define-component-inline-methods (ret rest)
2175 (dolist (name +asdf-methods+)
2176 (let ((keyword (intern (symbol-name name) :keyword)))
2177 (loop :for data = rest :then (cddr data)
2178 :for key = (first data)
2179 :for value = (second data)
2181 :when (eq key keyword) :do
2182 (destructuring-bind (op qual (o c) &body body) value
2184 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
2186 (component-inline-methods ret)))))))
2188 (defun %refresh-component-inline-methods (component rest)
2189 (%remove-component-inline-methods component)
2190 (%define-component-inline-methods component rest))
2192 (defun parse-component-form (parent options)
2194 (type name &rest rest &key
2195 ;; the following list of keywords is reproduced below in the
2196 ;; remove-keys form. important to keep them in sync
2197 components pathname default-component-class
2198 perform explain output-files operation-done-p
2200 depends-on serial in-order-to
2202 &allow-other-keys) options
2203 (declare (ignorable perform explain output-files operation-done-p))
2204 (check-component-input type name weakly-depends-on depends-on components in-order-to)
2207 (find-component parent name)
2208 ;; ignore the same object when rereading the defsystem
2210 (typep (find-component parent name)
2211 (class-for-type parent type))))
2212 (error 'duplicate-names :name name))
2214 (let* ((other-args (remove-keys
2215 '(components pathname default-component-class
2216 perform explain output-files operation-done-p
2218 depends-on serial in-order-to)
2221 (or (find-component parent name)
2222 (make-instance (class-for-type parent type)))))
2223 (when weakly-depends-on
2224 (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
2225 (when *serial-depends-on*
2226 (push *serial-depends-on* depends-on))
2227 (apply #'reinitialize-instance ret
2228 :name (coerce-name name)
2232 (component-pathname ret) ; eagerly compute the absolute pathname
2233 (when (typep ret 'module)
2234 (setf (module-default-component-class ret)
2235 (or default-component-class
2236 (and (typep parent 'module)
2237 (module-default-component-class parent))))
2238 (let ((*serial-depends-on* nil))
2239 (setf (module-components ret)
2241 :for c-form :in components
2242 :for c = (parse-component-form ret c-form)
2243 :for name = (component-name c)
2245 :when serial :do (setf *serial-depends-on* name))))
2246 (compute-module-components-by-name ret))
2248 (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
2250 (setf (component-in-order-to ret)
2251 (union-of-dependencies
2253 `((compile-op (compile-op ,@depends-on))
2254 (load-op (load-op ,@depends-on)))))
2255 (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
2257 (%refresh-component-inline-methods ret rest)
2260 ;;;; ---------------------------------------------------------------------------
2261 ;;;; run-shell-command
2263 ;;;; run-shell-command functions for other lisp implementations will be
2264 ;;;; gratefully accepted, if they do the same thing.
2265 ;;;; If the docstring is ambiguous, send a bug report.
2267 ;;;; We probably should move this functionality to its own system and deprecate
2268 ;;;; use of it from the asdf package. However, this would break unspecified
2269 ;;;; existing software, so until a clear alternative exists, we can't deprecate
2270 ;;;; it, and even after it's been deprecated, we will support it for a few
2271 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
2273 (defun run-shell-command (control-string &rest args)
2274 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
2275 synchronously execute the result using a Bourne-compatible shell, with
2276 output to *VERBOSE-OUT*. Returns the shell's exit code."
2277 (let ((command (apply #'format nil control-string args)))
2278 (asdf-message "; $ ~A~%" command)
2281 (ext:run-shell-command command :output *verbose-out*)
2284 ;; will this fail if command has embedded quotes - it seems to work
2285 (multiple-value-bind (stdout stderr exit-code)
2286 (excl.osi:command-output
2287 (format nil "~a -c \"~a\""
2288 #+mswindows "sh" #-mswindows "/bin/sh" command)
2289 :input nil :whole nil
2290 #+mswindows :show-window #+mswindows :hide)
2291 (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
2292 (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
2295 #+clisp ;XXX not exactly *verbose-out*, I know
2296 (ext:run-shell-command command :output :terminal :wait t)
2300 (ccl:external-process-status
2301 (ccl:run-program "/bin/sh" (list "-c" command)
2302 :input nil :output *verbose-out*
2305 #+ecl ;; courtesy of Juan Jose Garcia Ripoll
2309 (lisp:system command)
2312 (system:call-system-showing-output
2314 :shell-type "/bin/sh"
2317 :output-stream *verbose-out*)
2320 (sb-ext:process-exit-code
2321 (apply #'sb-ext:run-program
2322 #+win32 "sh" #-win32 "/bin/sh"
2324 :input nil :output *verbose-out*
2325 #+win32 '(:search t) #-win32 nil))
2328 (ext:process-exit-code
2332 :input nil :output *verbose-out*))
2334 #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
2335 (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
2337 ;;;; ---------------------------------------------------------------------------
2338 ;;;; system-relative-pathname
2340 (defmethod system-source-file ((system-name string))
2341 (system-source-file (find-system system-name)))
2342 (defmethod system-source-file ((system-name symbol))
2343 (system-source-file (find-system system-name)))
2345 (defun system-source-directory (system-designator)
2346 "Return a pathname object corresponding to the
2347 directory in which the system specification (.asd file) is
2349 (make-pathname :name nil
2351 :defaults (system-source-file system-designator)))
2353 (defun relativize-directory (directory)
2355 ((stringp directory)
2356 (list :relative directory))
2357 ((eq (car directory) :absolute)
2358 (cons :relative (cdr directory)))
2362 (defun relativize-pathname-directory (pathspec)
2363 (let ((p (pathname pathspec)))
2365 :directory (relativize-directory (pathname-directory p))
2368 (defun system-relative-pathname (system name &key type)
2370 (merge-component-name-type name :type type)
2371 (system-source-directory system)))
2374 ;;; ---------------------------------------------------------------------------
2375 ;;; implementation-identifier
2377 ;;; produce a string to identify current implementation.
2378 ;;; Initially stolen from SLIME's SWANK, hacked since.
2380 (defparameter *implementation-features*
2381 '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
2382 :corman :cormanlisp :armedbear :gcl :ecl :scl))
2384 (defparameter *os-features*
2385 '((:windows :mswindows :win32 :mingw32)
2387 :linux ;; for GCL at least, must appear before :bsd.
2388 :macosx :darwin :apple
2389 :freebsd :netbsd :openbsd :bsd
2392 (defparameter *architecture-features*
2393 '((:x86-64 :amd64 :x86_64 :x8664-target)
2394 (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
2395 :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc))
2397 (defun lisp-version-string ()
2398 (let ((s (lisp-implementation-version)))
2399 (declare (ignorable s))
2400 #+allegro (format nil
2402 excl::*common-lisp-version-number*
2403 ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
2404 (if (eq excl:*current-case-mode*
2405 :case-sensitive-lower) "M" "A")
2406 ;; Note if not using International ACL
2407 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
2408 (excl:ics-target-case
2411 (if (member :64bit *features*) "-64bit" ""))
2412 #+clisp (subseq s 0 (position #\space s))
2413 #+clozure (format nil "~d.~d-fasl~d"
2414 ccl::*openmcl-major-version*
2415 ccl::*openmcl-minor-version*
2416 (logand ccl::fasl-version #xFF))
2417 #+cmu (substitute #\- #\/ s)
2418 #+digitool (subseq s 8)
2419 #+ecl (format nil "~A~@[-~A~]" s
2420 (let ((vcs-id (ext:lisp-implementation-vcs-id)))
2421 (when (>= (length vcs-id) 8)
2422 (subseq vcs-id 0 8))))
2423 #+gcl (subseq s (1+ (position #\space s)))
2424 #+lispworks (format nil "~A~@[~A~]" s
2425 (when (member :lispworks-64bit *features*) "-64bit"))
2426 ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
2427 #+(or armedbear cormanlisp mcl sbcl scl) s
2428 #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
2429 ecl gcl lispworks mcl sbcl scl) s))
2431 (defun first-feature (features)
2436 (let ((feature (find thing *features*)))
2437 (when feature (return-from fp feature))))
2438 ;; allows features to be lists of which the first
2439 ;; member is the "main name", the rest being aliases
2441 (dolist (subf thing)
2442 (when (find subf *features*) (return-from fp (first thing))))))
2444 (loop :for f :in features
2445 :when (fp f) :return :it)))
2447 (defun implementation-type ()
2448 (first-feature *implementation-features*))
2450 (defun implementation-identifier ()
2452 ((maybe-warn (value fstring &rest args)
2454 (t (apply #'warn fstring args)
2456 (let ((lisp (maybe-warn (implementation-type)
2457 "No implementation feature found in ~a."
2458 *implementation-features*))
2459 (os (maybe-warn (first-feature *os-features*)
2460 "No os feature found in ~a." *os-features*))
2461 (arch (maybe-warn (first-feature *architecture-features*)
2462 "No architecture feature found in ~a."
2463 *architecture-features*))
2464 (version (maybe-warn (lisp-version-string)
2465 "Don't know how to get Lisp ~
2466 implementation version.")))
2468 #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
2469 (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
2473 ;;; ---------------------------------------------------------------------------
2474 ;;; Generic support for configuration files
2476 (defparameter *inter-directory-separator*
2477 #+(or unix cygwin) #\:
2478 #-(or unix cygwin) #\;)
2480 (defun user-homedir ()
2481 (truename (user-homedir-pathname)))
2483 (defun try-directory-subpath (x sub &key type)
2484 (let* ((p (and x (ensure-directory-pathname x)))
2485 (tp (and p (ignore-errors (truename p))))
2486 (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
2487 (ts (and sp (ignore-errors (truename sp)))))
2488 (and ts (values sp ts))))
2489 (defun user-configuration-directories ()
2492 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
2493 `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
2494 ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
2495 :for dir :in (split-string dirs :separator ":")
2496 :collect (try dir "common-lisp/"))
2497 #+(and (or win32 windows mswindows mingw32) (not cygwin))
2498 ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
2499 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
2500 ,(try (getenv "APPDATA") "common-lisp/config/"))
2501 ,(try (user-homedir) ".config/common-lisp/")))))
2502 (defun system-configuration-directories ()
2506 #+(and (or win32 windows mswindows mingw32) (not cygwin))
2507 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
2508 `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
2509 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
2510 ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
2512 (defun in-first-directory (dirs x)
2513 (loop :for dir :in dirs
2514 :thereis (and dir (ignore-errors
2515 (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
2516 (defun in-user-configuration-directory (x)
2517 (in-first-directory (user-configuration-directories) x))
2518 (defun in-system-configuration-directory (x)
2519 (in-first-directory (system-configuration-directories) x))
2521 (defun configuration-inheritance-directive-p (x)
2522 (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
2524 (and (length=n-p x 1) (member (car x) kw)))))
2526 (defun validate-configuration-form (form tag directive-validator
2527 &optional (description tag))
2528 (unless (and (consp form) (eq (car form) tag))
2529 (error "Error: Form doesn't specify ~A ~S~%" description form))
2530 (loop :with inherit = 0
2531 :for directive :in (cdr form) :do
2532 (if (configuration-inheritance-directive-p directive)
2534 (funcall directive-validator directive))
2536 (unless (= inherit 1)
2537 (error "One and only one of ~S or ~S is required"
2538 :inherit-configuration :ignore-inherited-configuration)))
2541 (defun validate-configuration-file (file validator description)
2542 (let ((forms (read-file-forms file)))
2543 (unless (length=n-p forms 1)
2544 (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
2545 (funcall validator (car forms))))
2547 (defun hidden-file-p (pathname)
2548 (equal (first-char (pathname-name pathname)) #\.))
2550 (defun validate-configuration-directory (directory tag validator)
2551 (let ((files (sort (ignore-errors
2554 (directory (make-pathname :name :wild :type "conf" :defaults directory)
2555 #+sbcl :resolve-symlinks #+sbcl nil)))
2556 #'string< :key #'namestring)))
2558 ,@(loop :for file :in files :append
2559 (mapcar validator (read-file-forms file)))
2560 :inherit-configuration)))
2563 ;;; ---------------------------------------------------------------------------
2564 ;;; asdf-output-translations
2566 ;;; this code is heavily inspired from
2567 ;;; asdf-binary-translations, common-lisp-controller and cl-launch.
2568 ;;; ---------------------------------------------------------------------------
2570 (defvar *output-translations* ()
2571 "Either NIL (for uninitialized), or a list of one element,
2572 said element itself being a sorted list of mappings.
2573 Each mapping is a pair of a source pathname and destination pathname,
2574 and the order is by decreasing length of namestring of the source pathname.")
2576 (defvar *user-cache*
2577 (flet ((try (x &rest sub) (and x `(,x ,@sub))))
2579 (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
2580 #+(and (or win32 windows mswindows mingw32) (not cygwin))
2581 (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
2582 '(:home ".cache" "common-lisp" :implementation))))
2583 (defvar *system-cache*
2584 ;; No good default, plus there's a security problem
2585 ;; with other users messing with such directories.
2588 (defun output-translations ()
2589 (car *output-translations*))
2591 (defun (setf output-translations) (new-value)
2592 (setf *output-translations*
2594 (stable-sort (copy-list new-value) #'>
2599 (length (pathname-directory (car x)))))))))
2602 (defun output-translations-initialized-p ()
2603 (and *output-translations* t))
2605 (defun clear-output-translations ()
2606 "Undoes any initialization of the output translations.
2607 You might want to call that before you dump an image that would be resumed
2608 with a different configuration, so the configuration would be re-read then."
2609 (setf *output-translations* '())
2612 (defparameter *wild-asd*
2613 (make-pathname :directory '(:relative :wild-inferiors)
2614 :name :wild :type "asd" :version :newest))
2617 (declaim (ftype (function (t &optional boolean) (or null pathname))
2620 (defun resolve-relative-location-component (super x &optional wildenp)
2621 (let* ((r (etypecase x
2625 (let ((car (resolve-relative-location-component super (car x) nil)))
2628 (let ((cdr (resolve-relative-location-component
2629 (merge-pathnames* car super) (cdr x) wildenp)))
2630 (merge-pathnames* cdr car)))))
2631 ((eql :default-directory)
2632 (relativize-pathname-directory (default-directory)))
2633 ((eql :implementation) (implementation-identifier))
2634 ((eql :implementation-type) (string-downcase (implementation-type)))
2635 #-(and (or win32 windows mswindows mingw32) (not cygwin))
2636 ((eql :uid) (princ-to-string (get-uid)))))
2637 (d (if (pathnamep x) r (ensure-directory-pathname r)))
2638 (s (if (and wildenp (not (pathnamep x)))
2641 (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
2642 (error "pathname ~S is not relative to ~S" s super))
2643 (merge-pathnames* s super)))
2645 (defun resolve-absolute-location-component (x wildenp)
2649 (string (ensure-directory-pathname x))
2651 (let ((car (resolve-absolute-location-component (car x) nil)))
2654 (let ((cdr (resolve-relative-location-component
2655 car (cdr x) wildenp)))
2656 (merge-pathnames* cdr car)))))
2658 ;; special magic! we encode such paths as relative pathnames,
2659 ;; but it means "relative to the root of the source pathname's host and device".
2660 (return-from resolve-absolute-location-component
2661 (make-pathname :directory '(:relative))))
2662 ((eql :home) (user-homedir))
2663 ((eql :user-cache) (resolve-location *user-cache* nil))
2664 ((eql :system-cache) (resolve-location *system-cache* nil))
2665 ((eql :default-directory) (default-directory))))
2666 (s (if (and wildenp (not (pathnamep x)))
2669 (unless (absolute-pathname-p s)
2670 (error "Not an absolute pathname ~S" s))
2673 (defun resolve-location (x &optional wildenp)
2675 (resolve-absolute-location-component x wildenp)
2676 (loop :with path = (resolve-absolute-location-component (car x) nil)
2677 :for (component . morep) :on (cdr x)
2678 :do (setf path (resolve-relative-location-component
2679 path component (and wildenp (not morep))))
2680 :finally (return path))))
2682 (defun location-designator-p (x)
2683 (flet ((componentp (c) (typep c '(or string pathname keyword))))
2684 (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
2686 (defun location-function-p (x)
2690 (or (and (equal (first x) :function)
2691 (typep (second x) 'symbol))
2692 (and (equal (first x) 'lambda)
2694 (length=n-p (second x) 2)))))
2696 (defun validate-output-translations-directive (directive)
2698 (or (member directive '(:inherit-configuration
2699 :ignore-inherited-configuration
2700 :enable-user-cache :disable-cache))
2701 (and (consp directive)
2702 (or (and (length=n-p directive 2)
2703 (or (and (eq (first directive) :include)
2704 (typep (second directive) '(or string pathname null)))
2705 (and (location-designator-p (first directive))
2706 (or (location-designator-p (second directive))
2707 (location-function-p (second directive))))))
2708 (and (length=n-p directive 1)
2709 (location-designator-p (first directive))))))
2710 (error "Invalid directive ~S~%" directive))
2713 (defun validate-output-translations-form (form)
2714 (validate-configuration-form
2716 :output-translations
2717 'validate-output-translations-directive
2718 "output translations"))
2720 (defun validate-output-translations-file (file)
2721 (validate-configuration-file
2722 file 'validate-output-translations-form "output translations"))
2724 (defun validate-output-translations-directory (directory)
2725 (validate-configuration-directory
2726 directory :output-translations 'validate-output-translations-directive))
2728 (defun parse-output-translations-string (string)
2730 ((or (null string) (equal string ""))
2731 '(:output-translations :inherit-configuration))
2732 ((not (stringp string))
2733 (error "environment string isn't: ~S" string))
2734 ((eql (char string 0) #\")
2735 (parse-output-translations-string (read-from-string string)))
2736 ((eql (char string 0) #\()
2737 (validate-output-translations-form (read-from-string string)))
2741 :with directives = ()
2743 :with end = (length string)
2745 :for i = (or (position *inter-directory-separator* string :start start) end) :do
2746 (let ((s (subseq string start i)))
2749 (push (list source (if (equal "" s) nil s)) directives)
2753 (error "only one inherited configuration allowed: ~S" string))
2755 (push :inherit-configuration directives))
2761 (error "Uneven number of components in source to destination mapping ~S" string))
2763 (push :ignore-inherited-configuration directives))
2764 (return `(:output-translations ,@(nreverse directives)))))))))
2766 (defparameter *default-output-translations*
2767 '(environment-output-translations
2768 user-output-translations-pathname
2769 user-output-translations-directory-pathname
2770 system-output-translations-pathname
2771 system-output-translations-directory-pathname))
2773 (defun wrapping-output-translations ()
2774 `(:output-translations
2775 ;; Some implementations have precompiled ASDF systems,
2776 ;; so we must disable translations for implementation paths.
2777 #+sbcl (,(getenv "SBCL_HOME") ())
2778 #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
2779 #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
2780 ;; All-import, here is where we want user stuff to be:
2781 :inherit-configuration
2782 ;; These are for convenience, and can be overridden by the user:
2783 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
2784 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
2785 ;; If we want to enable the user cache by default, here would be the place:
2786 :enable-user-cache))
2788 (defparameter *output-translations-file* #p"asdf-output-translations.conf")
2789 (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
2791 (defun user-output-translations-pathname ()
2792 (in-user-configuration-directory *output-translations-file* ))
2793 (defun system-output-translations-pathname ()
2794 (in-system-configuration-directory *output-translations-file*))
2795 (defun user-output-translations-directory-pathname ()
2796 (in-user-configuration-directory *output-translations-directory*))
2797 (defun system-output-translations-directory-pathname ()
2798 (in-system-configuration-directory *output-translations-directory*))
2799 (defun environment-output-translations ()
2800 (getenv "ASDF_OUTPUT_TRANSLATIONS"))
2802 (defgeneric process-output-translations (spec &key inherit collect))
2803 (declaim (ftype (function (t &key (:collect (or symbol function))) t)
2804 inherit-output-translations))
2805 (declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
2806 process-output-translations-directive))
2808 (defmethod process-output-translations ((x symbol) &key
2809 (inherit *default-output-translations*)
2811 (process-output-translations (funcall x) :inherit inherit :collect collect))
2812 (defmethod process-output-translations ((pathname pathname) &key inherit collect)
2814 ((directory-pathname-p pathname)
2815 (process-output-translations (validate-output-translations-directory pathname)
2816 :inherit inherit :collect collect))
2817 ((probe-file pathname)
2818 (process-output-translations (validate-output-translations-file pathname)
2819 :inherit inherit :collect collect))
2821 (inherit-output-translations inherit :collect collect))))
2822 (defmethod process-output-translations ((string string) &key inherit collect)
2823 (process-output-translations (parse-output-translations-string string)
2824 :inherit inherit :collect collect))
2825 (defmethod process-output-translations ((x null) &key inherit collect)
2826 (declare (ignorable x))
2827 (inherit-output-translations inherit :collect collect))
2828 (defmethod process-output-translations ((form cons) &key inherit collect)
2829 (dolist (directive (cdr (validate-output-translations-form form)))
2830 (process-output-translations-directive directive :inherit inherit :collect collect)))
2832 (defun inherit-output-translations (inherit &key collect)
2834 (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
2836 (defun process-output-translations-directive (directive &key inherit collect)
2837 (if (atom directive)
2839 ((:enable-user-cache)
2840 (process-output-translations-directive '(t :user-cache) :collect collect))
2842 (process-output-translations-directive '(t t) :collect collect))
2843 ((:inherit-configuration)
2844 (inherit-output-translations inherit :collect collect))
2845 ((:ignore-inherited-configuration)
2847 (let ((src (first directive))
2848 (dst (second directive)))
2849 (if (eq src :include)
2851 (process-output-translations (pathname dst) :inherit nil :collect collect))
2853 (let ((trusrc (or (eql src t)
2854 (let ((loc (resolve-location src t)))
2855 (if (absolute-pathname-p loc) (truenamize loc) loc)))))
2857 ((location-function-p dst)
2860 (if (symbolp (second dst))
2861 (fdefinition (second dst))
2862 (eval (second dst))))))
2864 (funcall collect (list trusrc t)))
2866 (let* ((trudst (make-pathname
2867 :defaults (if dst (resolve-location dst t) trusrc)))
2868 (wilddst (make-pathname
2869 :name :wild :type :wild :version :wild
2871 (funcall collect (list wilddst t))
2872 (funcall collect (list trusrc trudst)))))))))))
2874 (defun compute-output-translations (&optional parameter)
2875 "read the configuration, return it"
2877 (while-collecting (c)
2878 (inherit-output-translations
2879 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
2880 :test 'equal :from-end t))
2882 (defun initialize-output-translations (&optional parameter)
2883 "read the configuration, initialize the internal configuration variable,
2884 return the configuration"
2885 (setf (output-translations) (compute-output-translations parameter)))
2887 (defun disable-output-translations ()
2888 "Initialize output translations in a way that maps every file to itself,
2889 effectively disabling the output translation facility."
2890 (initialize-output-translations
2891 '(:output-translations :disable-cache :ignore-inherited-configuration)))
2893 ;; checks an initial variable to see whether the state is initialized
2894 ;; or cleared. In the former case, return current configuration; in
2895 ;; the latter, initialize. ASDF will call this function at the start
2896 ;; of (asdf:find-system).
2897 (defun ensure-output-translations ()
2898 (if (output-translations-initialized-p)
2899 (output-translations)
2900 (initialize-output-translations)))
2902 (defun apply-output-translations (path)
2906 ((or pathname string)
2907 (ensure-output-translations)
2908 (loop :with p = (truenamize path)
2909 :for (source destination) :in (car *output-translations*)
2910 :for root = (when (or (eq source t)
2911 (and (pathnamep source)
2912 (not (absolute-pathname-p source))))
2914 :for absolute-source = (cond
2915 ((eq source t) (wilden root))
2916 (root (merge-pathnames* source root))
2918 :when (or (eq source t) (pathname-match-p p absolute-source))
2921 ((functionp destination)
2922 (funcall destination p absolute-source))
2925 ((not (pathnamep destination))
2926 (error "invalid destination"))
2927 ((not (absolute-pathname-p destination))
2928 (translate-pathname p absolute-source (merge-pathnames* destination root)))
2930 (translate-pathname (directorize-pathname-host-device p) absolute-source destination))
2932 (translate-pathname p absolute-source destination)))
2933 :finally (return p)))))
2935 (defmethod output-files :around (operation component)
2936 "Translate output files, unless asked not to"
2937 (declare (ignorable operation component))
2939 (multiple-value-bind (files fixedp) (call-next-method)
2942 (mapcar #'apply-output-translations files)))
2945 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
2947 (apply-output-translations
2948 (apply 'compile-file-pathname
2949 (truenamize (lispize-pathname input-file))
2952 (defun tmpize-pathname (x)
2954 :name (format nil "ASDF-TMP-~A" (pathname-name x))
2957 (defun delete-file-if-exists (x)
2958 (when (probe-file x)
2961 (defun compile-file* (input-file &rest keys &key &allow-other-keys)
2962 (let* ((output-file (apply 'compile-file-pathname* input-file keys))
2963 (tmp-file (tmpize-pathname output-file))
2965 (multiple-value-bind (output-truename warnings-p failure-p)
2966 (apply 'compile-file input-file :output-file tmp-file keys)
2969 (setf status *compile-file-failure-behaviour*))
2971 (setf status *compile-file-warnings-behaviour*))
2973 (setf status :success)))
2975 ((:success :warn :ignore)
2976 (delete-file-if-exists output-file)
2977 (when output-truename
2978 (rename-file output-truename output-file)
2979 (setf output-truename output-file)))
2981 (delete-file-if-exists output-truename)
2982 (setf output-truename nil)))
2983 (values output-truename warnings-p failure-p))))
2986 (defun translate-jar-pathname (source wildcard)
2987 (declare (ignore wildcard))
2988 (let* ((p (pathname (first (pathname-device source))))
2989 (root (format nil "/___jar___file___root___/~@[~A/~]"
2990 (and (find :windows *features*)
2991 (pathname-device p)))))
2992 (apply-output-translations
2994 (relativize-pathname-directory source)
2996 (relativize-pathname-directory (ensure-directory-pathname p))
2999 ;;;; -----------------------------------------------------------------
3000 ;;;; Compatibility mode for ASDF-Binary-Locations
3002 (defun enable-asdf-binary-locations-compatibility
3004 (centralize-lisp-binaries nil)
3005 (default-toplevel-directory
3006 ;; Use ".cache/common-lisp" instead ???
3007 (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
3009 (include-per-user-information nil)
3010 (map-all-source-files nil)
3011 (source-to-target-mappings nil))
3012 (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
3013 (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
3014 (mapped-files (make-pathname
3015 :name :wild :version :wild
3016 :type (if map-all-source-files :wild fasl-type)))
3017 (destination-directory
3018 (if centralize-lisp-binaries
3019 `(,default-toplevel-directory
3020 ,@(when include-per-user-information
3021 (cdr (pathname-directory (user-homedir))))
3022 :implementation ,wild-inferiors)
3023 `(:root ,wild-inferiors :implementation))))
3024 (initialize-output-translations
3025 `(:output-translations
3026 ,@source-to-target-mappings
3027 ((:root ,wild-inferiors ,mapped-files)
3028 (,@destination-directory ,mapped-files))
3030 :ignore-inherited-configuration))))
3032 ;;;; -----------------------------------------------------------------
3033 ;;;; Windows shortcut support. Based on:
3035 ;;;; Jesse Hager: The Windows Shortcut File Format.
3036 ;;;; http://www.wotsit.org/list.asp?fc=13
3038 (defparameter *link-initial-dword* 76)
3039 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
3041 (defun read-null-terminated-string (s)
3042 (with-output-to-string (out)
3043 (loop :for code = (read-byte s)
3045 :do (write-char (code-char code) out))))
3047 (defun read-little-endian (s &optional (bytes 4))
3049 :for i :from 0 :below bytes
3050 :sum (ash (read-byte s) (* 8 i))))
3052 (defun parse-file-location-info (s)
3053 (let ((start (file-position s))
3054 (total-length (read-little-endian s))
3055 (end-of-header (read-little-endian s))
3056 (fli-flags (read-little-endian s))
3057 (local-volume-offset (read-little-endian s))
3058 (local-offset (read-little-endian s))
3059 (network-volume-offset (read-little-endian s))
3060 (remaining-offset (read-little-endian s)))
3061 (declare (ignore total-length end-of-header local-volume-offset))
3062 (unless (zerop fli-flags)
3064 ((logbitp 0 fli-flags)
3065 (file-position s (+ start local-offset)))
3066 ((logbitp 1 fli-flags)
3067 (file-position s (+ start
3068 network-volume-offset
3070 (concatenate 'string
3071 (read-null-terminated-string s)
3073 (file-position s (+ start remaining-offset))
3074 (read-null-terminated-string s))))))
3076 (defun parse-windows-shortcut (pathname)
3077 (with-open-file (s pathname :element-type '(unsigned-byte 8))
3079 (when (and (= (read-little-endian s) *link-initial-dword*)
3080 (let ((header (make-array (length *link-guid*))))
3081 (read-sequence header s)
3082 (equalp header *link-guid*)))
3083 (let ((flags (read-little-endian s)))
3084 (file-position s 76) ;skip rest of header
3085 (when (logbitp 0 flags)
3086 ;; skip shell item id list
3087 (let ((length (read-little-endian s 2)))
3088 (file-position s (+ length (file-position s)))))
3091 (parse-file-location-info s))
3093 (when (logbitp 2 flags)
3094 ;; skip description string
3095 (let ((length (read-little-endian s 2)))
3096 (file-position s (+ length (file-position s)))))
3097 (when (logbitp 3 flags)
3098 ;; finally, our pathname
3099 (let* ((length (read-little-endian s 2))
3100 (buffer (make-array length)))
3101 (read-sequence buffer s)
3102 (map 'string #'code-char buffer)))))))
3106 ;;;; -----------------------------------------------------------------
3107 ;;;; Source Registry Configuration, by Francois-Rene Rideau
3108 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
3110 ;; Using ack 1.2 exclusions
3111 (defvar *default-source-registry-exclusions*
3112 '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
3113 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
3114 "_sgbak" "autom4te.cache" "cover_db" "_build"))
3116 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
3118 (defvar *source-registry* ()
3119 "Either NIL (for uninitialized), or a list of one element,
3120 said element itself being a list of directory pathnames where to look for .asd files")
3122 (defun source-registry ()
3123 (car *source-registry*))
3125 (defun (setf source-registry) (new-value)
3126 (setf *source-registry* (list new-value))
3129 (defun source-registry-initialized-p ()
3130 (and *source-registry* t))
3132 (defun clear-source-registry ()
3133 "Undoes any initialization of the source registry.
3134 You might want to call that before you dump an image that would be resumed
3135 with a different configuration, so the configuration would be re-read then."
3136 (setf *source-registry* '())
3139 (defun validate-source-registry-directive (directive)
3141 (or (member directive '(:default-registry (:default-registry)) :test 'equal)
3142 (destructuring-bind (kw &rest rest) directive
3144 ((:include :directory :tree)
3145 (and (length=n-p rest 1)
3146 (typep (car rest) '(or pathname string null))))
3147 ((:exclude :also-exclude)
3148 (every #'stringp rest))
3150 (error "Invalid directive ~S~%" directive))
3153 (defun validate-source-registry-form (form)
3154 (validate-configuration-form
3155 form :source-registry 'validate-source-registry-directive "a source registry"))
3157 (defun validate-source-registry-file (file)
3158 (validate-configuration-file
3159 file 'validate-source-registry-form "a source registry"))
3161 (defun validate-source-registry-directory (directory)
3162 (validate-configuration-directory
3163 directory :source-registry 'validate-source-registry-directive))
3165 (defun parse-source-registry-string (string)
3167 ((or (null string) (equal string ""))
3168 '(:source-registry :inherit-configuration))
3169 ((not (stringp string))
3170 (error "environment string isn't: ~S" string))
3171 ((find (char string 0) "\"(")
3172 (validate-source-registry-form (read-from-string string)))
3176 :with directives = ()
3178 :with end = (length string)
3179 :for pos = (position *inter-directory-separator* string :start start) :do
3180 (let ((s (subseq string start (or pos end))))
3182 ((equal "" s) ; empty element: inherit
3184 (error "only one inherited configuration allowed: ~S" string))
3186 (push ':inherit-configuration directives))
3188 (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
3190 (push `(:directory ,s) directives)))
3193 (setf start (1+ pos)))
3196 (push '(:ignore-inherited-configuration) directives))
3197 (return `(:source-registry ,@(nreverse directives))))))))))
3199 (defun register-asd-directory (directory &key recurse exclude collect)
3201 (funcall collect directory)
3204 (directory (merge-pathnames* *wild-asd* directory)
3205 #+sbcl #+sbcl :resolve-symlinks nil
3206 #+clisp #+clisp :circle t)
3208 (warn "Error while scanning system definitions under directory ~S:~%~A"
3211 (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
3212 :test #'equal :from-end t)))
3215 :unless (loop :for x :in exclude
3216 :thereis (find x (pathname-directory dir) :test #'equal))
3217 :do (funcall collect dir)))))
3219 (defparameter *default-source-registries*
3220 '(environment-source-registry
3221 user-source-registry
3222 user-source-registry-directory
3223 system-source-registry
3224 system-source-registry-directory
3225 default-source-registry))
3227 (defparameter *source-registry-file* #p"source-registry.conf")
3228 (defparameter *source-registry-directory* #p"source-registry.conf.d/")
3230 (defun wrapping-source-registry ()
3232 #+sbcl (:tree ,(getenv "SBCL_HOME"))
3233 :inherit-configuration
3234 #+cmu (:tree #p"modules:")))
3235 (defun default-source-registry ()
3236 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
3238 #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
3239 (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
3243 (or (getenv "XDG_DATA_HOME")
3244 (try (user-homedir) ".local/share/")))
3246 (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
3247 (dirs (cons datahome (split-string datadirs :separator ":"))))
3248 #+(and (or win32 windows mswindows mingw32) (not cygwin))
3249 ((datahome (getenv "APPDATA"))
3251 #+lispworks (sys:get-folder-path :local-appdata)
3252 #-lispworks (try (getenv "ALLUSERSPROFILE")
3253 "Application Data"))
3254 (dirs (list datahome datadir)))
3255 #-(or unix win32 windows mswindows mingw32 cygwin)
3257 (loop :for dir :in dirs
3258 :collect `(:directory ,(try dir "common-lisp/systems/"))
3259 :collect `(:tree ,(try dir "common-lisp/source/"))))
3260 :inherit-configuration)))
3261 (defun user-source-registry ()
3262 (in-user-configuration-directory *source-registry-file*))
3263 (defun system-source-registry ()
3264 (in-system-configuration-directory *source-registry-file*))
3265 (defun user-source-registry-directory ()
3266 (in-user-configuration-directory *source-registry-directory*))
3267 (defun system-source-registry-directory ()
3268 (in-system-configuration-directory *source-registry-directory*))
3269 (defun environment-source-registry ()
3270 (getenv "CL_SOURCE_REGISTRY"))
3272 (defgeneric process-source-registry (spec &key inherit register))
3273 (declaim (ftype (function (t &key (:register (or symbol function))) t)
3274 inherit-source-registry))
3275 (declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
3276 process-source-registry-directive))
3278 (defmethod process-source-registry ((x symbol) &key inherit register)
3279 (process-source-registry (funcall x) :inherit inherit :register register))
3280 (defmethod process-source-registry ((pathname pathname) &key inherit register)
3282 ((directory-pathname-p pathname)
3283 (process-source-registry (validate-source-registry-directory pathname)
3284 :inherit inherit :register register))
3285 ((probe-file pathname)
3286 (process-source-registry (validate-source-registry-file pathname)
3287 :inherit inherit :register register))
3289 (inherit-source-registry inherit :register register))))
3290 (defmethod process-source-registry ((string string) &key inherit register)
3291 (process-source-registry (parse-source-registry-string string)
3292 :inherit inherit :register register))
3293 (defmethod process-source-registry ((x null) &key inherit register)
3294 (declare (ignorable x))
3295 (inherit-source-registry inherit :register register))
3296 (defmethod process-source-registry ((form cons) &key inherit register)
3297 (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
3298 (dolist (directive (cdr (validate-source-registry-form form)))
3299 (process-source-registry-directive directive :inherit inherit :register register))))
3301 (defun inherit-source-registry (inherit &key register)
3303 (process-source-registry (first inherit) :register register :inherit (rest inherit))))
3305 (defun process-source-registry-directive (directive &key inherit register)
3306 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
3309 (destructuring-bind (pathname) rest
3310 (process-source-registry (pathname pathname) :inherit nil :register register)))
3312 (destructuring-bind (pathname) rest
3314 (funcall register (ensure-directory-pathname pathname)))))
3316 (destructuring-bind (pathname) rest
3318 (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
3320 (setf *source-registry-exclusions* rest))
3322 (appendf *source-registry-exclusions* rest))
3323 ((:default-registry)
3324 (inherit-source-registry '(default-source-registry) :register register))
3325 ((:inherit-configuration)
3326 (inherit-source-registry inherit :register register))
3327 ((:ignore-inherited-configuration)
3331 (defun flatten-source-registry (&optional parameter)
3333 (while-collecting (collect)
3334 (inherit-source-registry
3335 `(wrapping-source-registry
3337 ,@*default-source-registries*)
3338 :register (lambda (directory &key recurse exclude)
3339 (collect (list directory :recurse recurse :exclude exclude)))))
3340 :test 'equal :from-end t))
3342 ;; Will read the configuration and initialize all internal variables,
3343 ;; and return the new configuration.
3344 (defun compute-source-registry (&optional parameter)
3345 (while-collecting (collect)
3346 (dolist (entry (flatten-source-registry parameter))
3347 (destructuring-bind (directory &key recurse exclude) entry
3348 (register-asd-directory
3350 :recurse recurse :exclude exclude :collect #'collect)))))
3352 (defun initialize-source-registry (&optional parameter)
3353 (setf (source-registry) (compute-source-registry parameter)))
3355 ;; checks an initial variable to see whether the state is initialized
3356 ;; or cleared. In the former case, return current configuration; in
3357 ;; the latter, initialize. ASDF will call this function at the start
3358 ;; of (asdf:find-system).
3359 (defun ensure-source-registry ()
3360 (if (source-registry-initialized-p)
3362 (initialize-source-registry)))
3364 (defun sysdef-source-registry-search (system)
3365 (ensure-source-registry)
3366 (loop :with name = (coerce-name system)
3367 :for defaults :in (source-registry)
3368 :for file = (probe-asd name defaults)
3369 :when file :return file))
3371 ;;;; -----------------------------------------------------------------
3372 ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
3374 #+(or abcl clozure cmu ecl sbcl)
3376 (defun module-provide-asdf (name)
3378 ((style-warning #'muffle-warning)
3379 (missing-component (constantly nil))
3381 (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
3383 (let* ((*verbose-out* (make-broadcast-stream))
3384 (system (find-system (string-downcase name) nil)))
3386 (load-system system)
3388 (pushnew 'module-provide-asdf
3389 #+abcl sys::*module-provider-functions*
3390 #+clozure ccl:*module-provider-functions*
3391 #+cmu ext:*module-provider-functions*
3392 #+ecl si:*module-provider-functions*
3393 #+sbcl sb-ext:*module-provider-functions*))
3395 ;;;; -------------------------------------------------------------------------
3396 ;;;; Cleanups after hot-upgrade.
3397 ;;;; Things to do in case we're upgrading from a previous version of ASDF.
3398 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
3400 ;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
3401 (eval-when (:compile-toplevel :load-toplevel :execute)
3402 #+ecl ;; Support upgrade from before ECL went to 1.369
3403 (when (fboundp 'compile-op-system-p)
3404 (defmethod compile-op-system-p ((op compile-op))
3405 (getf :system-p (compile-op-flags op)))
3406 (defmethod initialize-instance :after ((op compile-op)
3408 &key system-p &allow-other-keys)
3409 (declare (ignorable initargs))
3410 (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
3412 ;;;; -----------------------------------------------------------------
3414 (when *load-verbose*
3415 (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
3418 (eval-when (:compile-toplevel :execute)
3419 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
3420 (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
3422 (pushnew :asdf *features*)
3423 (pushnew :asdf2 *features*)
3427 ;;; Local Variables: