Ignore:
Timestamp:
10/31/10 08:40:27 (12 years ago)
Author:
Mark Evenson
Message:

Upgrade to ASDF-2.010.1.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r12818 r12986  
    4848#+xcvb (module ())
    4949
    50 (cl:in-package :cl)
    51 (defpackage :asdf-bootstrap (:use :cl))
    52 (in-package :asdf-bootstrap)
    53 
    54 ;; Implementation-dependent tweaks
     50(cl:in-package :cl-user)
     51
     52#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
     53
    5554(eval-when (:compile-toplevel :load-toplevel :execute)
    56   ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
     55  ;;; make package if it doesn't exist yet.
     56  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
     57  (unless (find-package :asdf)
     58    (make-package :asdf :use '(:cl)))
     59  ;;; Implementation-dependent tweaks
     60  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
    5761  #+allegro
    5862  (setf excl::*autoload-package-name-alist*
    5963        (remove "asdf" excl::*autoload-package-name-alist*
    6064                :test 'equalp :key 'car))
    61   #+ecl (require :cmp)
    62   #+gcl
    63   (eval-when (:compile-toplevel :load-toplevel)
    64     (defpackage :asdf-utilities (:use :cl))
    65     (defpackage :asdf (:use :cl :asdf-utilities))))
     65  #+ecl (require :cmp))
     66
     67(in-package :asdf)
    6668
    6769;;;; Create packages in a way that is compatible with hot-upgrade.
     
    7072
    7173(eval-when (:load-toplevel :compile-toplevel :execute)
    72   (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
    73           (subseq "VERSION:2.004" (1+ (length "VERSION")))) ; NB: same as 2.111.
    74          (existing-asdf (find-package :asdf))
    75          (vername '#:*asdf-version*)
    76          (versym (and existing-asdf
    77                       (find-symbol (string vername) existing-asdf)))
    78          (existing-version (and versym (boundp versym) (symbol-value versym)))
     74  (defvar *asdf-version* nil)
     75  (defvar *upgraded-p* nil)
     76  (let* ((asdf-version "2.010.1") ;; bump this version when you modify this file. Same as 2.147
     77         (existing-asdf (fboundp 'find-system))
     78         (existing-version *asdf-version*)
    7979         (already-there (equal asdf-version existing-version)))
    8080    (unless (and existing-asdf already-there)
    81       #-gcl
    8281      (when existing-asdf
    83         (format *trace-output*
     82        (format *error-output*
    8483                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    8584                existing-version asdf-version))
    8685      (labels
    87           ((rename-away (package)
    88              (loop :with name = (package-name package)
    89                :for i :from 1 :for new = (format nil "~A.~D" name i)
    90                :unless (find-package new) :do
    91                (rename-package-name package name new)))
    92            (rename-package-name (package old new)
    93              (let* ((old-names (cons (package-name package)
    94                                      (package-nicknames package)))
    95                     (new-names (subst new old old-names :test 'equal))
    96                     (new-name (car new-names))
    97                     (new-nicknames (cdr new-names)))
    98                (rename-package package new-name new-nicknames)))
     86          ((unlink-package (package)
     87             (let ((u (find-package package)))
     88               (when u
     89                 (ensure-unintern u
     90                   (loop :for s :being :each :present-symbol :in u :collect s))
     91                 (loop :for p :in (package-used-by-list u) :do
     92                   (unuse-package u p))
     93                 (delete-package u))))
    9994           (ensure-exists (name nicknames use)
    100              (let* ((previous
    101                      (remove-duplicates
    102                       (remove-if
    103                        #'null
    104                        (mapcar #'find-package (cons name nicknames)))
    105                       :from-end t)))
    106                (cond
    107                  (previous
    108                   ;; do away with packages with conflicting (nick)names
    109                   (map () #'rename-away (cdr previous))
    110                   ;; reuse previous package with same name
    111                   (let ((p (car previous)))
     95             (let ((previous
     96                    (remove-duplicates
     97                     (mapcar #'find-package (cons name nicknames))
     98                     :from-end t)))
     99               ;; do away with packages with conflicting (nick)names
     100               (map () #'unlink-package (cdr previous))
     101               ;; reuse previous package with same name
     102               (let ((p (car previous)))
     103                 (cond
     104                   (p
    112105                    (rename-package p name nicknames)
    113106                    (ensure-use p use)
    114                     p))
    115                  (t
    116                   (make-package name :nicknames nicknames :use use)))))
     107                    p)
     108                   (t
     109                    (make-package name :nicknames nicknames :use use))))))
    117110           (find-sym (symbol package)
    118111             (find-symbol (string symbol) package))
     
    123116               (when sym
    124117                 (unexport sym package)
    125                  (unintern sym package))))
     118                 (unintern sym package)
     119                 sym)))
    126120           (ensure-unintern (package symbols)
    127              (dolist (sym symbols) (remove-symbol sym package)))
     121             (loop :with packages = (list-all-packages)
     122               :for sym :in symbols
     123               :for removed = (remove-symbol sym package)
     124               :when removed :do
     125               (loop :for p :in packages :do
     126                 (when (eq removed (find-sym sym p))
     127                   (unintern removed p)))))
    128128           (ensure-shadow (package symbols)
    129129             (shadow symbols package))
     
    139139               :when sym :do (fmakunbound sym)))
    140140           (ensure-export (package export)
    141              (let ((syms (loop :for x :in export :collect
    142                            (intern* x package))))
    143                (do-external-symbols (sym package)
    144                  (unless (member sym syms)
    145                    (remove-symbol sym package)))
    146                (dolist (sym syms)
    147                  (export sym package))))
     141             (let ((formerly-exported-symbols nil)
     142                   (bothly-exported-symbols nil)
     143                   (newly-exported-symbols nil))
     144               (loop :for sym :being :each :external-symbol :in package :do
     145                 (if (member sym export :test 'string-equal)
     146                     (push sym bothly-exported-symbols)
     147                     (push sym formerly-exported-symbols)))
     148               (loop :for sym :in export :do
     149                 (unless (member sym bothly-exported-symbols :test 'string-equal)
     150                   (push sym newly-exported-symbols)))
     151               (loop :for user :in (package-used-by-list package)
     152                 :for shadowing = (package-shadowing-symbols user) :do
     153                 (loop :for new :in newly-exported-symbols
     154                   :for old = (find-sym new user)
     155                   :when (and old (not (member old shadowing)))
     156                   :do (unintern old user)))
     157               (loop :for x :in newly-exported-symbols :do
     158                 (export (intern* x package)))))
    148159           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
    149              (let ((p (ensure-exists name nicknames use)))
     160             (let* ((p (ensure-exists name nicknames use)))
    150161               (ensure-unintern p unintern)
    151162               (ensure-shadow p shadow)
     
    162173                   :fmakunbound ',(append fmakunbound))))
    163174          (pkgdcl
    164            :asdf-utilities
    165            :nicknames (#:asdf-extensions)
    166            :use (#:common-lisp)
    167            :unintern (#:split #:make-collector)
    168            :export
    169            (#:absolute-pathname-p
    170             #:aif
    171             #:appendf
    172             #:asdf-message
    173             #:coerce-name
    174             #:directory-pathname-p
    175             #:ends-with
    176             #:ensure-directory-pathname
    177             #:getenv
    178             #:get-uid
    179             #:length=n-p
    180             #:merge-pathnames*
    181             #:pathname-directory-pathname
    182             #:read-file-forms
    183             #:remove-keys
    184             #:remove-keyword
    185             #:resolve-symlinks
    186             #:split-string
    187             #:component-name-to-pathname-components
    188             #:split-name-type
    189             #:system-registered-p
    190             #:truenamize
    191             #:while-collecting))
    192           (pkgdcl
    193175           :asdf
    194            :use (:common-lisp :asdf-utilities)
     176           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
     177           :use (:common-lisp)
    195178           :redefined-functions
    196179           (#:perform #:explain #:output-files #:operation-done-p
    197180            #:perform-with-restarts #:component-relative-pathname
    198             #:system-source-file #:operate #:find-component)
     181            #:system-source-file #:operate #:find-component #:find-system
     182            #:apply-output-translations #:translate-pathname* #:resolve-location)
    199183           :unintern
    200184           (#:*asdf-revision* #:around #:asdf-method-combination
     
    208192           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
    209193            #:system-definition-pathname #:find-component ; miscellaneous
    210             #:compile-system #:load-system #:test-system
     194            #:compile-system #:load-system #:test-system #:clear-system
    211195            #:compile-op #:load-op #:load-source-op
    212196            #:test-op
     
    216200            #:version-satisfies
    217201
    218             #:input-files #:output-files #:perform ; operation methods
     202            #:input-files #:output-files #:output-file #:perform ; operation methods
    219203            #:operation-done-p #:explain
    220204
     
    255239            #:operation-on-warnings
    256240            #:operation-on-failure
     241            #:component-visited-p
    257242            ;;#:*component-parent-pathname*
    258243            #:*system-definition-search-functions*
     
    284269            #:remove-entry-from-registry
    285270
     271            #:clear-configuration
    286272            #:initialize-output-translations
    287273            #:disable-output-translations
     
    292278            #:compile-file-pathname*
    293279            #:enable-asdf-binary-locations-compatibility
    294 
    295280            #:*default-source-registries*
    296281            #:initialize-source-registry
     
    298283            #:clear-source-registry
    299284            #:ensure-source-registry
    300             #:process-source-registry)))
    301         (let* ((version (intern* vername :asdf))
    302                (upvar (intern* '#:*upgraded-p* :asdf))
    303                (upval0 (and (boundp upvar) (symbol-value upvar)))
    304                (upval1 (if existing-version (cons existing-version upval0) upval0)))
    305           (eval `(progn
    306                    (defparameter ,version ,asdf-version)
    307                    (defparameter ,upvar ',upval1))))))))
    308 
    309 (in-package :asdf)
     285            #:process-source-registry
     286            #:system-registered-p
     287            #:asdf-message
     288
     289            ;; Utilities
     290            #:absolute-pathname-p
     291      ;; #:aif #:it
     292            ;; #:appendf
     293            #:coerce-name
     294            #:directory-pathname-p
     295            ;; #:ends-with
     296            #:ensure-directory-pathname
     297            #:getenv
     298            ;; #:get-uid
     299            ;; #:length=n-p
     300            #:merge-pathnames*
     301            #:pathname-directory-pathname
     302            #:read-file-forms
     303      ;; #:remove-keys
     304      ;; #:remove-keyword
     305            #:resolve-symlinks
     306            #:split-string
     307            #:component-name-to-pathname-components
     308            #:split-name-type
     309            #:subdirectories
     310            #:truenamize
     311            #:while-collecting)))
     312        (setf *asdf-version* asdf-version
     313              *upgraded-p* (if existing-version
     314                               (cons existing-version *upgraded-p*)
     315                               *upgraded-p*))))))
    310316
    311317;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
    312 #+gcl
    313 (eval-when (:compile-toplevel :load-toplevel)
    314   (defvar *asdf-version* nil)
    315   (defvar *upgraded-p* nil))
    316318(when *upgraded-p*
    317319   #+ecl
     
    327329           ((m module) added deleted plist &key)
    328330         (declare (ignorable deleted plist))
    329          (format *trace-output* "Updating ~A~%" m)
     331         (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
    330332         (when (member 'components-by-name added)
    331            (compute-module-components-by-name m))))))
     333           (compute-module-components-by-name m))
     334         (when (and (typep m 'system) (member 'source-file added))
     335           (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
    332336
    333337;;;; -------------------------------------------------------------------------
     
    343347  "Determine whether or not ASDF resolves symlinks when defining systems.
    344348
    345 Defaults to `t`.")
    346 
    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.")
    350 
    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.")
     349Defaults to T.")
     350
     351(defvar *compile-file-warnings-behaviour*
     352  (or #+clisp :ignore :warn)
     353  "How should ASDF react if it encounters a warning when compiling a file?
     354Valid values are :error, :warn, and :ignore.")
     355
     356(defvar *compile-file-failure-behaviour*
     357  (or #+sbcl :error #+clisp :ignore :warn)
     358  "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
     359when compiling a file?  Valid values are :error, :warn, and :ignore.
     360Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
    356361
    357362(defvar *verbose-out* nil)
     
    372377;;;; -------------------------------------------------------------------------
    373378;;;; ASDF Interface, in terms of generic functions.
    374 (defmacro defgeneric* (name formals &rest options)
    375   `(progn
    376      #+(or gcl ecl) (fmakunbound ',name)
    377      (defgeneric ,name ,formals ,@options)))
    378 
     379(macrolet
     380    ((defdef (def* def)
     381       `(defmacro ,def* (name formals &rest rest)
     382          `(progn
     383             #+(or ecl gcl) (fmakunbound ',name)
     384             ,(when (and #+ecl (symbolp name))
     385                `(declaim (notinline ,name))) ; fails for setf functions on ecl
     386             (,',def ,name ,formals ,@rest)))))
     387  (defdef defgeneric* defgeneric)
     388  (defdef defun* defun))
     389
     390(defgeneric* find-system (system &optional error-p))
    379391(defgeneric* perform-with-restarts (operation component))
    380392(defgeneric* perform (operation component))
     
    383395(defgeneric* output-files (operation component))
    384396(defgeneric* input-files (operation component))
    385 (defgeneric component-operation-time (operation component))
     397(defgeneric* component-operation-time (operation component))
     398(defgeneric* operation-description (operation component)
     399  (:documentation "returns a phrase that describes performing this operation
     400on this component, e.g. \"loading /a/b/c\".
     401You can put together sentences using this phrase."))
    386402
    387403(defgeneric* system-source-file (system)
    388404  (:documentation "Return the source file in which system is defined."))
    389405
    390 (defgeneric component-system (component)
     406(defgeneric* component-system (component)
    391407  (:documentation "Find the top-level system containing COMPONENT"))
    392408
    393 (defgeneric component-pathname (component)
     409(defgeneric* component-pathname (component)
    394410  (:documentation "Extracts the pathname applicable for a particular component."))
    395411
    396 (defgeneric component-relative-pathname (component)
     412(defgeneric* component-relative-pathname (component)
    397413  (:documentation "Returns a pathname for the component argument intended to be
    398414interpreted relative to the pathname of that component's parent.
     
    401417another pathname in a degenerate way."))
    402418
    403 (defgeneric component-property (component property))
    404 
    405 (defgeneric (setf component-property) (new-value component property))
    406 
    407 (defgeneric version-satisfies (component version))
     419(defgeneric* component-property (component property))
     420
     421(defgeneric* (setf component-property) (new-value component property))
     422
     423(defgeneric* version-satisfies (component version))
    408424
    409425(defgeneric* find-component (base path)
     
    411427if BASE is nil, then the component is assumed to be a system."))
    412428
    413 (defgeneric source-file-type (component system))
    414 
    415 (defgeneric operation-ancestor (operation)
     429(defgeneric* source-file-type (component system))
     430
     431(defgeneric* operation-ancestor (operation)
    416432  (:documentation
    417433   "Recursively chase the operation's parent pointer until we get to
    418434the head of the tree"))
    419435
    420 (defgeneric component-visited-p (operation component)
     436(defgeneric* component-visited-p (operation component)
    421437  (:documentation "Returns the value stored by a call to
    422438VISIT-COMPONENT, if that has been called, otherwise NIL.
     
    431447operations needed to be performed."))
    432448
    433 (defgeneric visit-component (operation component data)
     449(defgeneric* visit-component (operation component data)
    434450  (:documentation "Record DATA as being associated with OPERATION
    435451and COMPONENT.  This is a side-effecting function:  the association
     
    439455non-NIL.  Using the data field is probably very risky; if there is
    440456already a record for OPERATION X COMPONENT, DATA will be quietly
    441 discarded instead of recorded."))
    442 
    443 (defgeneric (setf visiting-component) (new-value operation component))
    444 
    445 (defgeneric component-visiting-p (operation component))
    446 
    447 (defgeneric component-depends-on (operation component)
     457discarded instead of recorded.
     458  Starting with 2.006, TRAVERSE will store an integer in data,
     459so that nodes can be sorted in decreasing order of traversal."))
     460
     461
     462(defgeneric* (setf visiting-component) (new-value operation component))
     463
     464(defgeneric* component-visiting-p (operation component))
     465
     466(defgeneric* component-depends-on (operation component)
    448467  (:documentation
    449468   "Returns a list of dependencies needed by the component to perform
     
    462481    list."))
    463482
    464 (defgeneric component-self-dependencies (operation component))
    465 
    466 (defgeneric traverse (operation component)
     483(defgeneric* component-self-dependencies (operation component))
     484
     485(defgeneric* traverse (operation component)
    467486  (:documentation
    468487"Generate and return a plan for performing OPERATION on COMPONENT.
     
    497516  `(let ((it ,test)) (if it ,then ,else)))
    498517
    499 (defun pathname-directory-pathname (pathname)
     518(defun* pathname-directory-pathname (pathname)
    500519  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    501520and NIL NAME, TYPE and VERSION components"
     
    503522    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    504523
    505 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     524(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    506525  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
    507526does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
     
    512531         (defaults (pathname defaults))
    513532         (directory (pathname-directory specified))
    514          #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
     533         (directory
     534          (cond
     535            #-(or sbcl cmu scl)
     536            ((stringp directory) `(:absolute ,directory) directory)
     537            #+gcl
     538            ((and (consp directory) (not (member (first directory) '(:absolute :relative))))
     539             `(:relative ,@directory))
     540            ((or (null directory)
     541                 (and (consp directory) (member (first directory) '(:absolute :relative))))
     542             directory)
     543            (t
     544             (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
    515545         (name (or (pathname-name specified) (pathname-name defaults)))
    516546         (type (or (pathname-type specified) (pathname-type defaults)))
     
    521551               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    522552      (multiple-value-bind (host device directory unspecific-handler)
    523           (#-gcl ecase #+gcl case (first directory)
     553          (ecase (first directory)
    524554            ((nil)
    525555             (values (pathname-host defaults)
     
    538568                         (append (pathname-directory defaults) (cdr directory))
    539569                         directory)
    540                      (unspecific-handler defaults)))
    541             #+gcl
    542             (t
    543              (assert (stringp (first directory)))
    544              (values (pathname-host defaults)
    545                      (pathname-device defaults)
    546                      (append (pathname-directory defaults) directory)
    547570                     (unspecific-handler defaults))))
    548571        (make-pathname :host host :device device :directory directory
     
    557580  or "or a flag")
    558581
    559 (defun first-char (s)
     582(defun* first-char (s)
    560583  (and (stringp s) (plusp (length s)) (char s 0)))
    561584
    562 (defun last-char (s)
     585(defun* last-char (s)
    563586  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    564587
    565 (defun asdf-message (format-string &rest format-args)
     588(defun* asdf-message (format-string &rest format-args)
    566589  (declare (dynamic-extent format-args))
    567590  (apply #'format *verbose-out* format-string format-args))
    568591
    569 (defun split-string (string &key max (separator '(#\Space #\Tab)))
     592(defun* split-string (string &key max (separator '(#\Space #\Tab)))
    570593  "Split STRING into a list of components separated by
    571594any of the characters in the sequence SEPARATOR.
     
    587610          (setf end start))))))
    588611
    589 (defun split-name-type (filename)
     612(defun* split-name-type (filename)
    590613  (let ((unspecific
    591614         ;; Giving :unspecific as argument to make-pathname is not portable.
     
    599622          (values name type)))))
    600623
    601 (defun component-name-to-pathname-components (s &optional force-directory)
     624(defun* component-name-to-pathname-components (s &key force-directory force-relative)
    602625  "Splits the path string S, returning three values:
    603626A flag that is either :absolute or :relative, indicating
     
    616639pathnames."
    617640  (check-type s string)
     641  (when (find #\: s)
     642    (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
    618643  (let* ((components (split-string s :separator "/"))
    619644         (last-comp (car (last components))))
     
    621646        (if (equal (first components) "")
    622647            (if (equal (first-char s) #\/)
    623                 (values :absolute (cdr components))
     648                (progn
     649                  (when force-relative
     650                    (error "absolute pathname designator not allowed: ~S" s))
     651                  (values :absolute (cdr components)))
    624652                (values :relative nil))
    625653          (values :relative components))
     
    633661         (values relative (butlast components) last-comp))))))
    634662
    635 (defun remove-keys (key-names args)
     663(defun* remove-keys (key-names args)
    636664  (loop :for (name val) :on args :by #'cddr
    637665    :unless (member (symbol-name name) key-names
     
    639667    :append (list name val)))
    640668
    641 (defun remove-keyword (key args)
     669(defun* remove-keyword (key args)
    642670  (loop :for (k v) :on args :by #'cddr
    643671    :unless (eq k key)
    644672    :append (list k v)))
    645673
    646 (defun getenv (x)
    647   #+abcl
    648   (ext:getenv x)
    649   #+sbcl
    650   (sb-ext:posix-getenv x)
    651   #+clozure
    652   (ccl:getenv x)
    653   #+clisp
    654   (ext:getenv x)
    655   #+cmu
    656   (cdr (assoc (intern x :keyword) ext:*environment-list*))
    657   #+lispworks
    658   (lispworks:environment-variable x)
    659   #+allegro
    660   (sys:getenv x)
    661   #+gcl
    662   (system:getenv x)
    663   #+ecl
    664   (si:getenv x))
    665 
    666 (defun directory-pathname-p (pathname)
     674(defun* getenv (x)
     675  (#+abcl ext:getenv
     676   #+allegro sys:getenv
     677   #+clisp ext:getenv
     678   #+clozure ccl:getenv
     679   #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
     680   #+ecl si:getenv
     681   #+gcl system:getenv
     682   #+lispworks lispworks:environment-variable
     683   #+sbcl sb-ext:posix-getenv
     684   x))
     685
     686(defun* directory-pathname-p (pathname)
    667687  "Does PATHNAME represent a directory?
    668688
     
    673693Note that this does _not_ check to see that PATHNAME points to an
    674694actually-existing directory."
    675   (flet ((check-one (x)
    676            (member x '(nil :unspecific "") :test 'equal)))
    677     (and (check-one (pathname-name pathname))
    678          (check-one (pathname-type pathname))
    679          t)))
    680 
    681 (defun ensure-directory-pathname (pathspec)
     695  (when pathname
     696    (let ((pathname (pathname pathname)))
     697      (flet ((check-one (x)
     698               (member x '(nil :unspecific "") :test 'equal)))
     699        (and (not (wild-pathname-p pathname))
     700             (check-one (pathname-name pathname))
     701             (check-one (pathname-type pathname))
     702             t)))))
     703
     704(defun* ensure-directory-pathname (pathspec)
    682705  "Converts the non-wild pathname designator PATHSPEC to directory form."
    683706  (cond
     
    687710    (error "Invalid pathname designator ~S" pathspec))
    688711   ((wild-pathname-p pathspec)
    689     (error "Can't reliably convert wild pathnames."))
     712    (error "Can't reliably convert wild pathname ~S" pathspec))
    690713   ((directory-pathname-p pathspec)
    691714    pathspec)
     
    697720                   :defaults pathspec))))
    698721
    699 (defun absolute-pathname-p (pathspec)
    700   (eq :absolute (car (pathname-directory (pathname pathspec)))))
    701 
    702 (defun length=n-p (x n) ;is it that (= (length x) n) ?
     722(defun* absolute-pathname-p (pathspec)
     723  (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
     724
     725(defun* length=n-p (x n) ;is it that (= (length x) n) ?
    703726  (check-type n (integer 0 *))
    704727  (loop
     
    709732      ((not (consp l)) (return nil)))))
    710733
    711 (defun ends-with (s suffix)
     734(defun* ends-with (s suffix)
    712735  (check-type s string)
    713736  (check-type suffix string)
     
    716739         (string-equal s suffix :start1 start))))
    717740
    718 (defun read-file-forms (file)
     741(defun* read-file-forms (file)
    719742  (with-open-file (in file)
    720743    (loop :with eof = (list nil)
     
    725748#-(and (or win32 windows mswindows mingw32) (not cygwin))
    726749(progn
    727 #+clisp (defun get-uid () (posix:uid))
    728 #+sbcl (defun get-uid () (sb-unix:unix-getuid))
    729 #+cmu (defun get-uid () (unix:unix-getuid))
    730 #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
    731          '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
    732 #+ecl (defun get-uid ()
    733         #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
    734             '(ffi:c-inline () () :int "getuid()" :one-liner t)
    735             '(ext::getuid)))
    736 #+allegro (defun get-uid () (excl.osi:getuid))
    737 #-(or cmu sbcl clisp allegro ecl)
    738 (defun get-uid ()
    739   (let ((uid-string
    740          (with-output-to-string (*verbose-out*)
    741            (run-shell-command "id -ur"))))
    742     (with-input-from-string (stream uid-string)
    743       (read-line stream)
    744       (handler-case (parse-integer (read-line stream))
    745         (error () (error "Unable to find out user ID")))))))
    746 
    747 (defun pathname-root (pathname)
     750  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
     751                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
     752  (defun* get-uid ()
     753    #+allegro (excl.osi:getuid)
     754    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
     755            :for f = (ignore-errors (read-from-string s))
     756                  :when f :return (funcall f))
     757    #+(or cmu scl) (unix:unix-getuid)
     758    #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
     759                   '(ffi:c-inline () () :int "getuid()" :one-liner t)
     760                   '(ext::getuid))
     761    #+sbcl (sb-unix:unix-getuid)
     762    #-(or allegro clisp cmu ecl sbcl scl)
     763    (let ((uid-string
     764           (with-output-to-string (*verbose-out*)
     765             (run-shell-command "id -ur"))))
     766      (with-input-from-string (stream uid-string)
     767        (read-line stream)
     768        (handler-case (parse-integer (read-line stream))
     769          (error () (error "Unable to find out user ID")))))))
     770
     771(defun* pathname-root (pathname)
    748772  (make-pathname :host (pathname-host pathname)
    749773                 :device (pathname-device pathname)
     
    751775                 :name nil :type nil :version nil))
    752776
    753 (defun truenamize (p)
     777(defun* probe-file* (p)
     778  "when given a pathname P, probes the filesystem for a file or directory
     779with given pathname and if it exists return its truename."
     780  (etypecase p
     781   (null nil)
     782   (string (probe-file* (parse-namestring p)))
     783   (pathname (unless (wild-pathname-p p)
     784               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
     785               #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
     786         '(ignore-errors (truename p)))))))
     787
     788(defun* truenamize (p)
    754789  "Resolve as much of a pathname as possible"
    755790  (block nil
     
    758793           (directory (pathname-directory p)))
    759794      (when (typep p 'logical-pathname) (return p))
    760       (ignore-errors (return (truename p)))
    761       #-sbcl (when (stringp directory) (return p))
     795      (let ((found (probe-file* p)))
     796        (when found (return found)))
     797      #-(or sbcl cmu) (when (stringp directory) (return p))
    762798      (when (not (eq :absolute (car directory))) (return p))
    763       (let ((sofar (ignore-errors (truename (pathname-root p)))))
     799      (let ((sofar (probe-file* (pathname-root p))))
    764800        (unless sofar (return p))
    765801        (flet ((solution (directories)
     
    773809          (loop :for component :in (cdr directory)
    774810            :for rest :on (cdr directory)
    775             :for more = (ignore-errors
    776                           (truename
    777                            (merge-pathnames*
    778                             (make-pathname :directory `(:relative ,component))
    779                             sofar))) :do
     811            :for more = (probe-file*
     812                         (merge-pathnames*
     813                          (make-pathname :directory `(:relative ,component))
     814                          sofar)) :do
    780815            (if more
    781816                (setf sofar more)
     
    784819            (return (solution nil))))))))
    785820
    786 (defun resolve-symlinks (path)
     821(defun* resolve-symlinks (path)
    787822  #-allegro (truenamize path)
    788823  #+allegro (excl:pathname-resolve-symbolic-links path))
    789824
    790 (defun default-directory ()
     825(defun* default-directory ()
    791826  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
    792827
    793 (defun lispize-pathname (input-file)
     828(defun* lispize-pathname (input-file)
    794829  (make-pathname :type "lisp" :defaults input-file))
    795830
     
    798833                 :name :wild :type :wild :version :wild))
    799834
    800 (defun wilden (path)
     835(defun* wilden (path)
    801836  (merge-pathnames* *wild-path* path))
    802837
    803 (defun directorize-pathname-host-device (pathname)
     838(defun* directorize-pathname-host-device (pathname)
    804839  (let* ((root (pathname-root pathname))
    805840         (wild-root (wilden root))
     
    814849                         root-namestring)))
    815850    (multiple-value-bind (relative path filename)
    816         (component-name-to-pathname-components root-string t)
     851        (component-name-to-pathname-components root-string :force-directory t)
    817852      (declare (ignore relative filename))
    818853      (let ((new-base
     
    838873                duplicate-names-name
    839874                error-component error-operation
    840                 module-components module-components-by-name)
     875                module-components module-components-by-name
     876                circular-dependency-components)
    841877         (ftype (function (t t) t) (setf module-components-by-name)))
    842878
     
    857893
    858894(define-condition circular-dependency (system-definition-error)
    859   ((components :initarg :components :reader circular-dependency-components)))
     895  ((components :initarg :components :reader circular-dependency-components))
     896  (:report (lambda (c s)
     897             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
    860898
    861899(define-condition duplicate-names (system-definition-error)
     
    893931         "Component name: designator for a string composed of portable pathname characters")
    894932   (version :accessor component-version :initarg :version)
     933   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
     934   ;; POIU is a parallel (multi-process build) extension of ASDF.  See
     935   ;; http://www.cliki.net/poiu
     936   (load-dependencies :accessor component-load-dependencies :initform nil)
     937   ;; In the ASDF object model, dependencies exist between *actions*
     938   ;; (an action is a pair of operation and component). They are represented
     939   ;; alists of operations to dependencies (other actions) in each component.
     940   ;; There are two kinds of dependencies, each stored in its own slot:
     941   ;; in-order-to and do-first dependencies. These two kinds are related to
     942   ;; the fact that some actions modify the filesystem,
     943   ;; whereas other actions modify the current image, and
     944   ;; this implies a difference in how to interpret timestamps.
     945   ;; in-order-to dependencies will trigger re-performing the action
     946   ;; when the timestamp of some dependency
     947   ;; makes the timestamp of current action out-of-date;
     948   ;; do-first dependencies do not trigger such re-performing.
     949   ;; Therefore, a FASL must be recompiled if it is obsoleted
     950   ;; by any of its FASL dependencies (in-order-to); but
     951   ;; it needn't be recompiled just because one of these dependencies
     952   ;; hasn't yet been loaded in the current image (do-first).
     953   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
    895954   (in-order-to :initform nil :initarg :in-order-to
    896955                :accessor component-in-order-to)
    897    ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
    898    (load-dependencies :accessor component-load-dependencies :initform nil)
    899    ;; XXX crap name, but it's an official API name!
    900956   (do-first :initform nil :initarg :do-first
    901957             :accessor component-do-first)
     
    916972               :initform nil)))
    917973
    918 (defun component-find-path (component)
     974(defun* component-find-path (component)
    919975  (reverse
    920976   (loop :for c = component :then (component-parent c)
     
    932988          (call-next-method c nil) (missing-required-by c)))
    933989
    934 (defun sysdef-error (format &rest arguments)
     990(defun* sysdef-error (format &rest arguments)
    935991  (error 'formatted-system-definition-error :format-control
    936992         format :format-arguments arguments))
     
    939995
    940996(defmethod print-object ((c missing-component) s)
    941    (format s "~@<component ~S not found~
    942              ~@[ in ~A~]~@:>"
     997  (format s "~@<component ~S not found~@[ in ~A~]~@:>"
    943998          (missing-requires c)
    944999          (when (missing-parent c)
     
    9461001
    9471002(defmethod print-object ((c missing-component-of-version) s)
    948   (format s "~@<component ~S does not match version ~A~
    949               ~@[ in ~A~]~@:>"
    950            (missing-requires c)
    951            (missing-version c)
    952            (when (missing-parent c)
    953              (component-name (missing-parent c)))))
     1003  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
     1004          (missing-requires c)
     1005          (missing-version c)
     1006          (when (missing-parent c)
     1007            (component-name (missing-parent c)))))
    9541008
    9551009(defmethod component-system ((component component))
     
    9601014(defvar *default-component-class* 'cl-source-file)
    9611015
    962 (defun compute-module-components-by-name (module)
     1016(defun* compute-module-components-by-name (module)
    9631017  (let ((hash (make-hash-table :test 'equal)))
    9641018    (setf (module-components-by-name module) hash)
     
    9901044    :accessor module-default-component-class)))
    9911045
    992 (defun component-parent-pathname (component)
     1046(defun* component-parent-pathname (component)
    9931047  ;; No default anymore (in particular, no *default-pathname-defaults*).
    9941048  ;; If you force component to have a NULL pathname, you better arrange
     
    10071061             (pathname-directory-pathname (component-parent-pathname component)))))
    10081062        (unless (or (null pathname) (absolute-pathname-p pathname))
    1009           (error "Invalid relative pathname ~S for component ~S" pathname component))
     1063          (error "Invalid relative pathname ~S for component ~S"
     1064                 pathname (component-find-path component)))
    10101065        (setf (slot-value component 'absolute-pathname) pathname)
    10111066        pathname)))
     
    10311086            :accessor system-license :initarg :license)
    10321087   (source-file :reader system-source-file :initarg :source-file
    1033                 :writer %set-system-source-file)))
     1088                :writer %set-system-source-file)
     1089   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
    10341090
    10351091;;;; -------------------------------------------------------------------------
     
    10581114;;;; Finding systems
    10591115
    1060 (defun make-defined-systems-table ()
     1116(defun* make-defined-systems-table ()
    10611117  (make-hash-table :test 'equal))
    10621118
     
    10681124of which is a system object.")
    10691125
    1070 (defun coerce-name (name)
     1126(defun* coerce-name (name)
    10711127  (typecase name
    10721128    (component (component-name name))
     
    10751131    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
    10761132
    1077 (defun system-registered-p (name)
     1133(defun* system-registered-p (name)
    10781134  (gethash (coerce-name name) *defined-systems*))
    10791135
    1080 (defun clear-system (name)
     1136(defun* clear-system (name)
    10811137  "Clear the entry for a system in the database of systems previously loaded.
    10821138Note that this does NOT in any way cause the code of the system to be unloaded."
     
    10891145  (setf (gethash (coerce-name name) *defined-systems*) nil))
    10901146
    1091 (defun map-systems (fn)
     1147(defun* map-systems (fn)
    10921148  "Apply FN to each defined system.
    10931149
     
    11071163  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    11081164
    1109 (defun system-definition-pathname (system)
     1165(defun* system-definition-pathname (system)
    11101166  (let ((system-name (coerce-name system)))
    11111167    (or
     
    11311187")
    11321188
    1133 (defun probe-asd (name defaults)
     1189(defun* probe-asd (name defaults)
    11341190  (block nil
    11351191    (when (directory-pathname-p defaults)
     
    11521208              (return (pathname target)))))))))
    11531209
    1154 (defun sysdef-central-registry-search (system)
     1210(defun* sysdef-central-registry-search (system)
    11551211  (let ((name (coerce-name system))
    11561212        (to-remove nil)
     
    11701226                                   (message
    11711227                                    (format nil
    1172                                             "~@<While searching for system ~S: ~S evaluated ~
    1173 to ~S which is not a directory.~@:>"
     1228                                            "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
    11741229                                            system dir defaults)))
    11751230                              (error message))
     
    11941249                          (subseq *central-registry* (1+ position))))))))))
    11951250
    1196 (defun make-temporary-package ()
     1251(defun* make-temporary-package ()
    11971252  (flet ((try (counter)
    11981253           (ignore-errors
     
    12031258         (package package))))
    12041259
    1205 (defun safe-file-write-date (pathname)
     1260(defun* safe-file-write-date (pathname)
    12061261  ;; If FILE-WRITE-DATE returns NIL, it's possible that
    12071262  ;; the user or some other agent has deleted an input file.
     
    12141269  (or (and pathname (probe-file pathname) (file-write-date pathname))
    12151270      (progn
    1216         (when pathname
     1271        (when (and pathname *asdf-verbose*)
    12171272          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
    12181273                pathname))
    12191274        0)))
    12201275
    1221 (defun find-system (name &optional (error-p t))
     1276(defmethod find-system (name &optional (error-p t))
     1277  (find-system (coerce-name name) error-p))
     1278
     1279(defmethod find-system ((name string) &optional (error-p t))
    12221280  (catch 'find-system
    1223     (let* ((name (coerce-name name))
    1224            (in-memory (system-registered-p name))
     1281    (let* ((in-memory (system-registered-p name))
    12251282           (on-disk (system-definition-pathname name)))
    12261283      (when (and on-disk
     
    12411298            (delete-package package))))
    12421299      (let ((in-memory (system-registered-p name)))
    1243         (if in-memory
    1244             (progn (when on-disk (setf (car in-memory)
    1245                                        (safe-file-write-date on-disk)))
    1246                    (cdr in-memory))
    1247             (when error-p (error 'missing-component :requires name)))))))
    1248 
    1249 (defun register-system (name system)
     1300        (cond
     1301          (in-memory
     1302           (when on-disk
     1303             (setf (car in-memory) (safe-file-write-date on-disk)))
     1304           (cdr in-memory))
     1305          (error-p
     1306           (error 'missing-component :requires name)))))))
     1307
     1308(defun* register-system (name system)
    12501309  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    12511310  (setf (gethash (coerce-name name) *defined-systems*)
    12521311        (cons (get-universal-time) system)))
    12531312
    1254 (defun sysdef-find-asdf (system)
    1255   (let ((name (coerce-name system)))
    1256     (when (equal name "asdf")
    1257       (let* ((registered (cdr (gethash name *defined-systems*)))
    1258              (asdf (or registered
    1259                        (make-instance
    1260                         'system :name "asdf"
    1261                         :source-file (or *compile-file-truename* *load-truename*)))))
    1262         (unless registered
    1263           (register-system "asdf" asdf))
    1264         (throw 'find-system asdf)))))
     1313(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
     1314  (setf fallback (coerce-name fallback)
     1315        source-file (or source-file *compile-file-truename* *load-truename*)
     1316        requested (coerce-name requested))
     1317  (when (equal requested fallback)
     1318    (let* ((registered (cdr (gethash fallback *defined-systems*)))
     1319           (system (or registered
     1320                       (apply 'make-instance 'system
     1321            :name fallback :source-file source-file keys))))
     1322      (unless registered
     1323        (register-system fallback system))
     1324      (throw 'find-system system))))
     1325
     1326(defun* sysdef-find-asdf (name)
     1327  (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
    12651328
    12661329
     
    13181381  (source-file-explicit-type component))
    13191382
    1320 (defun merge-component-name-type (name &key type defaults)
     1383(defun* merge-component-name-type (name &key type defaults)
    13211384  ;; The defaults are required notably because they provide the default host
    13221385  ;; to the below make-pathname, which may crucially matter to people using
     
    13251388  ;; but that should only matter if you either (a) use absolute pathnames, or
    13261389  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
    1327   ;; ASDF-UTILITIES:MERGE-PATHNAMES*
     1390  ;; ASDF:MERGE-PATHNAMES*
    13281391  (etypecase name
    13291392    (pathname
     
    13331396    (string
    13341397     (multiple-value-bind (relative path filename)
    1335          (component-name-to-pathname-components name (eq type :directory))
     1398         (component-name-to-pathname-components name :force-directory (eq type :directory)
     1399                                                :force-relative t)
    13361400       (multiple-value-bind (name type)
    13371401           (cond
     
    13701434   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    13711435   ;;   to force systems named in a given list
    1372    ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
     1436   ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
    13731437   (forced :initform nil :initarg :force :accessor operation-forced)
    13741438   (original-initargs :initform nil :initarg :original-initargs
     
    13901454  (values))
    13911455
    1392 (defun node-for (o c)
     1456(defun* node-for (o c)
    13931457  (cons (class-name (class-of o)) c))
    13941458
     
    13991463
    14001464
    1401 (defun make-sub-operation (c o dep-c dep-o)
     1465(defun* make-sub-operation (c o dep-c dep-o)
    14021466  "C is a component, O is an operation, DEP-C is another
    14031467component, and DEP-O, confusingly enough, is an operation
     
    15441608recursive calls to traverse.")
    15451609
    1546 (defgeneric do-traverse (operation component collect))
    1547 
    1548 (defun %do-one-dep (operation c collect required-op required-c required-v)
     1610(defgeneric* do-traverse (operation component collect))
     1611
     1612(defun* %do-one-dep (operation c collect required-op required-c required-v)
    15491613  ;; collects a partial plan that results from performing required-op
    15501614  ;; on required-c, possibly with a required-vERSION
     
    15621626    (do-traverse op dep-c collect)))
    15631627
    1564 (defun do-one-dep (operation c collect required-op required-c required-v)
    1565   ;; this function is a thin, error-handling wrapper around
    1566   ;; %do-one-dep.  Returns a partial plan per that function.
     1628(defun* do-one-dep (operation c collect required-op required-c required-v)
     1629  ;; this function is a thin, error-handling wrapper around %do-one-dep.
     1630  ;; Collects a partial plan per that function.
    15671631  (loop
    15681632    (restart-case
     
    15721636        :report (lambda (s)
    15731637                  (format s "~@<Retry loading component ~S.~@:>"
    1574                           required-c))
     1638                          (component-find-path required-c)))
    15751639        :test
    15761640        (lambda (c)
    1577           #|
    1578           (print (list :c1 c (typep c 'missing-dependency)))
    1579           (when (typep c 'missing-dependency)
    1580           (print (list :c2 (missing-requires c) required-c
    1581           (equalp (missing-requires c)
    1582           required-c))))
    1583           |#
    15841641          (or (null c)
    15851642              (and (typep c 'missing-dependency)
     
    15871644                           required-c))))))))
    15881645
    1589 (defun do-dep (operation c collect op dep)
     1646(defun* do-dep (operation c collect op dep)
    15901647  ;; type of arguments uncertain:
    15911648  ;; op seems to at least potentially be a symbol, rather than an operation
     
    16261683           flag))))
    16271684
    1628 (defun do-collect (collect x)
     1685(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
     1686
     1687(defun* do-collect (collect x)
    16291688  (funcall collect x))
    16301689
     
    17111770                 (do-collect collect (cons operation c)))))
    17121771             (setf (visiting-component operation c) nil)))
    1713       (visit-component operation c flag)
     1772      (visit-component operation c (when flag (incf *visit-count*)))
    17141773      flag))
    17151774
    1716 (defun flatten-tree (l)
     1775(defun* flatten-tree (l)
    17171776  ;; You collected things into a list.
    17181777  ;; Most elements are just things to collect again.
     
    17411800  (flatten-tree
    17421801   (while-collecting (collect)
    1743      (do-traverse operation c #'collect))))
     1802     (let ((*visit-count* 0))
     1803       (do-traverse operation c #'collect)))))
    17441804
    17451805(defmethod perform ((operation operation) (c source-file))
    17461806  (sysdef-error
    1747    "~@<required method PERFORM not implemented ~
    1748     for operation ~A, component ~A~@:>"
     1807   "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
    17491808   (class-of operation) (class-of c)))
    17501809
     
    17541813
    17551814(defmethod explain ((operation operation) (component component))
    1756   (asdf-message "~&;;; ~A on ~A~%" operation component))
     1815  (asdf-message "~&;;; ~A~%" (operation-description operation component)))
     1816
     1817(defmethod operation-description (operation component)
     1818  (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
    17571819
    17581820;;;; -------------------------------------------------------------------------
     
    17681830          :initform #-ecl nil #+ecl '(:system-p t))))
    17691831
     1832(defun output-file (operation component)
     1833  "The unique output file of performing OPERATION on COMPONENT"
     1834  (let ((files (output-files operation component)))
     1835    (assert (length=n-p files 1))
     1836    (first files)))
     1837
    17701838(defmethod perform :before ((operation compile-op) (c source-file))
    17711839  (map nil #'ensure-directories-exist (output-files operation c)))
     
    17841852        (get-universal-time)))
    17851853
    1786 (declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
     1854(declaim (ftype (function ((or pathname string)
     1855                           &rest t &key (:output-file t) &allow-other-keys)
    17871856                          (values t t t))
    17881857                compile-file*))
     
    17931862  #-:broken-fasl-loader
    17941863  (let ((source-file (component-pathname c))
    1795         (output-file (car (output-files operation c)))
     1864        ;; on some implementations, there are more than one output-file,
     1865        ;; but the first one should always be the primary fasl that gets loaded.
     1866        (output-file (first (output-files operation c)))
    17961867        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
    17971868        (*compile-file-failure-behaviour* (operation-on-failure operation)))
     
    18361907  nil)
    18371908
     1909(defmethod operation-description ((operation compile-op) component)
     1910  (declare (ignorable operation))
     1911  (format nil "compiling component ~S" (component-find-path component)))
    18381912
    18391913;;;; -------------------------------------------------------------------------
     
    18451919
    18461920(defmethod perform ((o load-op) (c cl-source-file))
    1847   #-ecl (mapcar #'load (input-files o c))
    1848   #+ecl (loop :for i :in (input-files o c)
    1849           :unless (string= (pathname-type i) "fas")
    1850           :collect (let ((output (compile-file-pathname (lispize-pathname i))))
    1851                      (load output))))
     1921  (map () #'load
     1922       #-ecl (input-files o c)
     1923       #+ecl (loop :for i :in (input-files o c)
     1924               :unless (string= (pathname-type i) "fas")
     1925               :collect (compile-file-pathname (lispize-pathname i)))))
    18521926
    18531927(defmethod perform-with-restarts (operation component)
     
    19121986        (call-next-method)))
    19131987
     1988(defmethod operation-description ((operation load-op) component)
     1989  (declare (ignorable operation))
     1990  (format nil "loading component ~S" (component-find-path component)))
     1991
     1992
    19141993;;;; -------------------------------------------------------------------------
    19151994;;;; load-source-op
     
    19492028             (component-property c 'last-loaded-as-source)))
    19502029      nil t))
     2030
     2031(defmethod operation-description ((operation load-source-op) component)
     2032  (declare (ignorable operation))
     2033  (format nil "loading component ~S" (component-find-path component)))
    19512034
    19522035
     
    19992082                :report
    20002083                (lambda (s)
    2001                   (format s "~@<Retry performing ~S on ~S.~@:>"
    2002                           op component)))
     2084                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
    20032085              (accept ()
    20042086                :report
    20052087                (lambda (s)
    2006                   (format s "~@<Continue, treating ~S on ~S as ~
    2007                                    having been successful.~@:>"
    2008                           op component))
     2088                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
     2089                          (operation-description op component)))
    20092090                (setf (gethash (type-of op)
    20102091                               (component-operation-times component))
    20112092                      (get-universal-time))
    2012                 (return)))))))
    2013     op))
    2014 
    2015 (defun oos (operation-class system &rest args &key force verbose version
     2093                (return))))))
     2094      (values op steps))))
     2095
     2096(defun* oos (operation-class system &rest args &key force verbose version
    20162097            &allow-other-keys)
    20172098  (declare (ignore force verbose version))
     
    20432124        operate-docstring))
    20442125
    2045 (defun load-system (system &rest args &key force verbose version
     2126(defun* load-system (system &rest args &key force verbose version
    20462127                    &allow-other-keys)
    20472128  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
    20482129details."
    20492130  (declare (ignore force verbose version))
    2050   (apply #'operate 'load-op system args))
    2051 
    2052 (defun compile-system (system &rest args &key force verbose version
     2131  (apply #'operate 'load-op system args)
     2132  t)
     2133
     2134(defun* compile-system (system &rest args &key force verbose version
    20532135                       &allow-other-keys)
    20542136  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
    20552137for details."
    20562138  (declare (ignore force verbose version))
    2057   (apply #'operate 'compile-op system args))
    2058 
    2059 (defun test-system (system &rest args &key force verbose version
     2139  (apply #'operate 'compile-op system args)
     2140  t)
     2141
     2142(defun* test-system (system &rest args &key force verbose version
    20602143                    &allow-other-keys)
    20612144  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
    20622145details."
    20632146  (declare (ignore force verbose version))
    2064   (apply #'operate 'test-op system args))
     2147  (apply #'operate 'test-op system args)
     2148  t)
    20652149
    20662150;;;; -------------------------------------------------------------------------
    20672151;;;; Defsystem
    20682152
    2069 (defun load-pathname ()
     2153(defun* load-pathname ()
    20702154  (let ((pn (or *load-pathname* *compile-file-pathname*)))
    20712155    (if *resolve-symlinks*
     
    20732157        pn)))
    20742158
    2075 (defun determine-system-pathname (pathname pathname-supplied-p)
     2159(defun* determine-system-pathname (pathname pathname-supplied-p)
    20762160  ;; The defsystem macro calls us to determine
    20772161  ;; the pathname of a system as follows:
     
    20822166         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
    20832167    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
    2084         file-pathname
     2168        directory-pathname
    20852169        (default-directory))))
    20862170
     
    20892173                            defsystem-depends-on &allow-other-keys)
    20902174      options
    2091     (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
     2175    (let ((component-options (remove-keys '(:class) options)))
    20922176      `(progn
    20932177         ;; system must be registered before we parse the body, otherwise
     
    21132197               ',component-options))))))
    21142198
    2115 (defun class-for-type (parent type)
     2199(defun* class-for-type (parent type)
    21162200  (or (loop :for symbol :in (list
    21172201                             (unless (keywordp type) type)
     
    21262210      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
    21272211
    2128 (defun maybe-add-tree (tree op1 op2 c)
     2212(defun* maybe-add-tree (tree op1 op2 c)
    21292213  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
    21302214Returns the new tree (which probably shares structure with the old one)"
     
    21412225        (acons op1 (list (list op2 c)) tree))))
    21422226
    2143 (defun union-of-dependencies (&rest deps)
     2227(defun* union-of-dependencies (&rest deps)
    21442228  (let ((new-tree nil))
    21452229    (dolist (dep deps)
     
    21542238(defvar *serial-depends-on* nil)
    21552239
    2156 (defun sysdef-error-component (msg type name value)
     2240(defun* sysdef-error-component (msg type name value)
    21572241  (sysdef-error (concatenate 'string msg
    21582242                             "~&The value specified for ~(~A~) ~A is ~S")
    21592243                type name value))
    21602244
    2161 (defun check-component-input (type name weakly-depends-on
     2245(defun* check-component-input (type name weakly-depends-on
    21622246                              depends-on components in-order-to)
    21632247  "A partial test of the values of a component."
     
    21752259                            type name in-order-to)))
    21762260
    2177 (defun %remove-component-inline-methods (component)
     2261(defun* %remove-component-inline-methods (component)
    21782262  (dolist (name +asdf-methods+)
    21792263    (map ()
     
    21872271  (setf (component-inline-methods component) nil))
    21882272
    2189 (defun %define-component-inline-methods (ret rest)
     2273(defun* %define-component-inline-methods (ret rest)
    21902274  (dolist (name +asdf-methods+)
    21912275    (let ((keyword (intern (symbol-name name) :keyword)))
     
    22012285           (component-inline-methods ret)))))))
    22022286
    2203 (defun %refresh-component-inline-methods (component rest)
     2287(defun* %refresh-component-inline-methods (component rest)
    22042288  (%remove-component-inline-methods component)
    22052289  (%define-component-inline-methods component rest))
    22062290
    2207 (defun parse-component-form (parent options)
     2291(defun* parse-component-form (parent options)
    22082292  (destructuring-bind
    22092293        (type name &rest rest &key
     
    22862370;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
    22872371
    2288 (defun run-shell-command (control-string &rest args)
     2372(defun* run-shell-command (control-string &rest args)
    22892373  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    22902374synchronously execute the result using a Bourne-compatible shell, with
     
    23582442  (system-source-file (find-system system-name)))
    23592443
    2360 (defun system-source-directory (system-designator)
     2444(defun* system-source-directory (system-designator)
    23612445  "Return a pathname object corresponding to the
    23622446directory in which the system specification (.asd file) is
     
    23662450                 :defaults (system-source-file system-designator)))
    23672451
    2368 (defun relativize-directory (directory)
     2452(defun* relativize-directory (directory)
    23692453  (cond
    23702454    ((stringp directory)
     
    23752459     directory)))
    23762460
    2377 (defun relativize-pathname-directory (pathspec)
     2461(defun* relativize-pathname-directory (pathspec)
    23782462  (let ((p (pathname pathspec)))
    23792463    (make-pathname
     
    23812465     :defaults p)))
    23822466
    2383 (defun system-relative-pathname (system name &key type)
     2467(defun* system-relative-pathname (system name &key type)
    23842468  (merge-pathnames*
    23852469   (merge-component-name-type name :type type)
     
    23942478
    23952479(defparameter *implementation-features*
    2396   '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
    2397     :corman :cormanlisp :armedbear :gcl :ecl :scl))
     2480  '((:acl :allegro)
     2481    (:lw :lispworks)
     2482    (:digitool) ; before clozure, so it won't get preempted by ccl
     2483    (:ccl :clozure)
     2484    (:corman :cormanlisp)
     2485    (:abcl :armedbear)
     2486    :sbcl :cmu :clisp :gcl :ecl :scl))
    23982487
    23992488(defparameter *os-features*
    2400   '((:windows :mswindows :win32 :mingw32)
     2489  '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    24012490    (:solaris :sunos)
    2402     :linux ;; for GCL at least, must appear before :bsd.
    2403     :macosx :darwin :apple
     2491    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
     2492    (:macosx :darwin :darwin-target :apple)
    24042493    :freebsd :netbsd :openbsd :bsd
    24052494    :unix))
    24062495
    24072496(defparameter *architecture-features*
    2408   '((:x86-64 :amd64 :x86_64 :x8664-target)
    2409     (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
    2410     :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
    2411     :java-1.4 :java-1.5 :java-1.6 :java-1.7))
    2412 
    2413 
    2414 (defun lisp-version-string ()
     2497  '((:amd64 :x86-64 :x86_64 :x8664-target)
     2498    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
     2499    :hppa64
     2500    :hppa
     2501    (:ppc64 :ppc64-target)
     2502    (:ppc32 :ppc32-target :ppc :powerpc)
     2503    :sparc64
     2504    (:sparc32 :sparc)
     2505    (:arm :arm-target)
     2506    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
     2507
     2508(defun* lisp-version-string ()
    24152509  (let ((s (lisp-implementation-version)))
    24162510    (declare (ignorable s))
     
    24292523    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    24302524    #+clisp (subseq s 0 (position #\space s))
    2431     #+clozure (format nil "~d.~d-fasl~d"
     2525    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    24322526                      ccl::*openmcl-major-version*
    24332527                      ccl::*openmcl-minor-version*
     
    24472541          ecl gcl lispworks mcl sbcl scl) s))
    24482542
    2449 (defun first-feature (features)
     2543(defun* first-feature (features)
    24502544  (labels
    24512545      ((fp (thing)
     
    24632557      :when (fp f) :return :it)))
    24642558
    2465 (defun implementation-type ()
     2559(defun* implementation-type ()
    24662560  (first-feature *implementation-features*))
    24672561
    2468 (defun implementation-identifier ()
     2562(defun* implementation-identifier ()
    24692563  (labels
    24702564      ((maybe-warn (value fstring &rest args)
     
    24812575                            *architecture-features*))
    24822576          (version (maybe-warn (lisp-version-string)
    2483                                "Don't know how to get Lisp ~
    2484                                           implementation version.")))
     2577                               "Don't know how to get Lisp implementation version.")))
    24852578      (substitute-if
    24862579       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
     
    24962589  #-(or unix cygwin) #\;)
    24972590
    2498 (defun user-homedir ()
     2591(defun* user-homedir ()
    24992592  (truename (user-homedir-pathname)))
    25002593
    2501 (defun try-directory-subpath (x sub &key type)
     2594(defun* try-directory-subpath (x sub &key type)
    25022595  (let* ((p (and x (ensure-directory-pathname x)))
    2503          (tp (and p (ignore-errors (truename p))))
     2596         (tp (and p (probe-file* p)))
    25042597         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
    2505          (ts (and sp (ignore-errors (truename sp)))))
     2598         (ts (and sp (probe-file* sp))))
    25062599    (and ts (values sp ts))))
    2507 (defun user-configuration-directories ()
     2600(defun* user-configuration-directories ()
    25082601  (remove-if
    25092602   #'null
     
    25182611           ,(try (getenv "APPDATA") "common-lisp/config/"))
    25192612       ,(try (user-homedir) ".config/common-lisp/")))))
    2520 (defun system-configuration-directories ()
     2613(defun* system-configuration-directories ()
    25212614  (remove-if
    25222615   #'null
     
    25282621        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    25292622    (list #p"/etc/common-lisp/"))))
    2530 (defun in-first-directory (dirs x)
     2623(defun* in-first-directory (dirs x)
    25312624  (loop :for dir :in dirs
    2532     :thereis (and dir (ignore-errors
    2533                         (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
    2534 (defun in-user-configuration-directory (x)
     2625    :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
     2626(defun* in-user-configuration-directory (x)
    25352627  (in-first-directory (user-configuration-directories) x))
    2536 (defun in-system-configuration-directory (x)
     2628(defun* in-system-configuration-directory (x)
    25372629  (in-first-directory (system-configuration-directories) x))
    25382630
    2539 (defun configuration-inheritance-directive-p (x)
     2631(defun* configuration-inheritance-directive-p (x)
    25402632  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
    25412633    (or (member x kw)
    25422634        (and (length=n-p x 1) (member (car x) kw)))))
    25432635
    2544 (defun validate-configuration-form (form tag directive-validator
     2636(defun* validate-configuration-form (form tag directive-validator
    25452637                                    &optional (description tag))
    25462638  (unless (and (consp form) (eq (car form) tag))
     
    25572649  form)
    25582650
    2559 (defun validate-configuration-file (file validator description)
     2651(defun* validate-configuration-file (file validator description)
    25602652  (let ((forms (read-file-forms file)))
    25612653    (unless (length=n-p forms 1)
     
    25632655    (funcall validator (car forms))))
    25642656
    2565 (defun hidden-file-p (pathname)
     2657(defun* hidden-file-p (pathname)
    25662658  (equal (first-char (pathname-name pathname)) #\.))
    25672659
    2568 (defun validate-configuration-directory (directory tag validator)
     2660(defun* validate-configuration-directory (directory tag validator)
    25692661  (let ((files (sort (ignore-errors
    25702662                       (remove-if
     
    26042696  *user-cache*)
    26052697
    2606 (defun output-translations ()
     2698(defun* output-translations ()
    26072699  (car *output-translations*))
    26082700
    2609 (defun (setf output-translations) (new-value)
     2701(defun* (setf output-translations) (new-value)
    26102702  (setf *output-translations*
    26112703        (list
     
    26182710  new-value)
    26192711
    2620 (defun output-translations-initialized-p ()
     2712(defun* output-translations-initialized-p ()
    26212713  (and *output-translations* t))
    26222714
    2623 (defun clear-output-translations ()
     2715(defun* clear-output-translations ()
    26242716  "Undoes any initialization of the output translations.
    26252717You might want to call that before you dump an image that would be resumed
     
    26282720  (values))
    26292721
    2630 (defparameter *wild-asd*
    2631   (make-pathname :directory '(:relative :wild-inferiors)
    2632                  :name :wild :type "asd" :version :newest))
    2633 
    2634 
    2635 (declaim (ftype (function (t &optional boolean) (or null pathname))
     2722(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
     2723                          (values (or null pathname) &optional))
    26362724                resolve-location))
    26372725
    2638 (defun resolve-relative-location-component (super x &optional wildenp)
     2726(defun* resolve-relative-location-component (super x &key directory wilden)
    26392727  (let* ((r (etypecase x
    26402728              (pathname x)
    26412729              (string x)
    26422730              (cons
    2643                (let ((car (resolve-relative-location-component super (car x) nil)))
     2731               (return-from resolve-relative-location-component
    26442732                 (if (null (cdr x))
    2645                      car
    2646                      (let ((cdr (resolve-relative-location-component
    2647                                  (merge-pathnames* car super) (cdr x) wildenp)))
     2733                     (resolve-relative-location-component
     2734                      super (car x) :directory directory :wilden wilden)
     2735                     (let* ((car (resolve-relative-location-component
     2736                                  super (car x) :directory t :wilden nil))
     2737                            (cdr (resolve-relative-location-component
     2738                                  (merge-pathnames* car super) (cdr x)
     2739                                  :directory directory :wilden wilden)))
    26482740                       (merge-pathnames* cdr car)))))
    26492741              ((eql :default-directory)
     
    26532745              #-(and (or win32 windows mswindows mingw32) (not cygwin))
    26542746              ((eql :uid) (princ-to-string (get-uid)))))
    2655          (d (if (pathnamep x) r (ensure-directory-pathname r)))
    2656          (s (if (and wildenp (not (pathnamep x)))
    2657                 (wilden d)
    2658                 d)))
     2747         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
     2748         (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
    26592749    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    26602750      (error "pathname ~S is not relative to ~S" s super))
    26612751    (merge-pathnames* s super)))
    26622752
    2663 (defun resolve-absolute-location-component (x wildenp)
     2753(defun* resolve-absolute-location-component (x &key directory wilden)
    26642754  (let* ((r
    26652755          (etypecase x
    26662756            (pathname x)
    2667             (string (ensure-directory-pathname x))
     2757            (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
    26682758            (cons
    2669              (let ((car (resolve-absolute-location-component (car x) nil)))
     2759             (return-from resolve-absolute-location-component
    26702760               (if (null (cdr x))
    2671                    car
    2672                    (let ((cdr (resolve-relative-location-component
    2673                                car (cdr x) wildenp)))
    2674                      (merge-pathnames* cdr car)))))
     2761                   (resolve-absolute-location-component
     2762                    (car x) :directory directory :wilden wilden)
     2763                   (let* ((car (resolve-absolute-location-component
     2764                                (car x) :directory t :wilden nil))
     2765                          (cdr (resolve-relative-location-component
     2766                                car (cdr x) :directory directory :wilden wilden)))
     2767                     (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
    26752768            ((eql :root)
    26762769             ;; special magic! we encode such paths as relative pathnames,
    26772770             ;; but it means "relative to the root of the source pathname's host and device".
    26782771             (return-from resolve-absolute-location-component
    2679                (make-pathname :directory '(:relative))))
     2772               (let ((p (make-pathname :directory '(:relative))))
     2773                 (if wilden (wilden p) p))))
    26802774            ((eql :home) (user-homedir))
    2681             ((eql :user-cache) (resolve-location *user-cache* nil))
    2682             ((eql :system-cache) (resolve-location *system-cache* nil))
     2775            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
     2776            ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
    26832777            ((eql :default-directory) (default-directory))))
    2684          (s (if (and wildenp (not (pathnamep x)))
     2778         (s (if (and wilden (not (pathnamep x)))
    26852779                (wilden r)
    26862780                r)))
     
    26892783    s))
    26902784
    2691 (defun resolve-location (x &optional wildenp)
     2785(defun* resolve-location (x &key directory wilden)
    26922786  (if (atom x)
    2693       (resolve-absolute-location-component x wildenp)
    2694       (loop :with path = (resolve-absolute-location-component (car x) nil)
     2787      (resolve-absolute-location-component x :directory directory :wilden wilden)
     2788      (loop :with path = (resolve-absolute-location-component
     2789                          (car x) :directory (and (or directory (cdr x)) t)
     2790                          :wilden (and wilden (null (cdr x))))
    26952791        :for (component . morep) :on (cdr x)
     2792        :for dir = (and (or morep directory) t)
     2793        :for wild = (and wilden (not morep))
    26962794        :do (setf path (resolve-relative-location-component
    2697                         path component (and wildenp (not morep))))
     2795                        path component :directory dir :wilden wild))
    26982796        :finally (return path))))
    26992797
    2700 (defun location-designator-p (x)
     2798(defun* location-designator-p (x)
    27012799  (flet ((componentp (c) (typep c '(or string pathname keyword))))
    27022800    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
    27032801
    2704 (defun location-function-p (x)
     2802(defun* location-function-p (x)
    27052803  (and
    27062804   (consp x)
     
    27122810            (length=n-p (second x) 2)))))
    27132811
    2714 (defun validate-output-translations-directive (directive)
     2812(defun* validate-output-translations-directive (directive)
    27152813  (unless
    27162814      (or (member directive '(:inherit-configuration
    27172815                              :ignore-inherited-configuration
    2718                               :enable-user-cache :disable-cache))
     2816                              :enable-user-cache :disable-cache nil))
    27192817          (and (consp directive)
    27202818               (or (and (length=n-p directive 2)
     
    27292827  directive)
    27302828
    2731 (defun validate-output-translations-form (form)
     2829(defun* validate-output-translations-form (form)
    27322830  (validate-configuration-form
    27332831   form
     
    27362834   "output translations"))
    27372835
    2738 (defun validate-output-translations-file (file)
     2836(defun* validate-output-translations-file (file)
    27392837  (validate-configuration-file
    27402838   file 'validate-output-translations-form "output translations"))
    27412839
    2742 (defun validate-output-translations-directory (directory)
     2840(defun* validate-output-translations-directory (directory)
    27432841  (validate-configuration-directory
    27442842   directory :output-translations 'validate-output-translations-directive))
    27452843
    2746 (defun parse-output-translations-string (string)
     2844(defun* parse-output-translations-string (string)
    27472845  (cond
    27482846    ((or (null string) (equal string ""))
     
    27892887    system-output-translations-directory-pathname))
    27902888
    2791 (defun wrapping-output-translations ()
     2889(defun* wrapping-output-translations ()
    27922890  `(:output-translations
    27932891    ;; Some implementations have precompiled ASDF systems,
    27942892    ;; so we must disable translations for implementation paths.
    2795     #+sbcl (,(getenv "SBCL_HOME") ())
     2893    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
    27962894    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    2797     #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
     2895    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
    27982896    ;; All-import, here is where we want user stuff to be:
    27992897    :inherit-configuration
     
    28012899    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    28022900    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    2803     ;; If we want to enable the user cache by default, here would be the place:
     2901    ;; We enable the user cache by default, and here is the place we do:
    28042902    :enable-user-cache))
    28052903
     
    28072905(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
    28082906
    2809 (defun user-output-translations-pathname ()
     2907(defun* user-output-translations-pathname ()
    28102908  (in-user-configuration-directory *output-translations-file* ))
    2811 (defun system-output-translations-pathname ()
     2909(defun* system-output-translations-pathname ()
    28122910  (in-system-configuration-directory *output-translations-file*))
    2813 (defun user-output-translations-directory-pathname ()
     2911(defun* user-output-translations-directory-pathname ()
    28142912  (in-user-configuration-directory *output-translations-directory*))
    2815 (defun system-output-translations-directory-pathname ()
     2913(defun* system-output-translations-directory-pathname ()
    28162914  (in-system-configuration-directory *output-translations-directory*))
    2817 (defun environment-output-translations ()
     2915(defun* environment-output-translations ()
    28182916  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
    28192917
    2820 (defgeneric process-output-translations (spec &key inherit collect))
     2918(defgeneric* process-output-translations (spec &key inherit collect))
    28212919(declaim (ftype (function (t &key (:collect (or symbol function))) t)
    28222920                inherit-output-translations))
     
    28482946    (process-output-translations-directive directive :inherit inherit :collect collect)))
    28492947
    2850 (defun inherit-output-translations (inherit &key collect)
     2948(defun* inherit-output-translations (inherit &key collect)
    28512949  (when inherit
    28522950    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
    28532951
    2854 (defun process-output-translations-directive (directive &key inherit collect)
     2952(defun* process-output-translations-directive (directive &key inherit collect)
    28552953  (if (atom directive)
    28562954      (ecase directive
     
    28612959        ((:inherit-configuration)
    28622960         (inherit-output-translations inherit :collect collect))
    2863         ((:ignore-inherited-configuration)
     2961        ((:ignore-inherited-configuration nil)
    28642962         nil))
    28652963      (let ((src (first directive))
     
    28702968            (when src
    28712969              (let ((trusrc (or (eql src t)
    2872                                 (let ((loc (resolve-location src t)))
     2970                                (let ((loc (resolve-location src :directory t :wilden t)))
    28732971                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
    28742972                (cond
     
    28832981                  (t
    28842982                   (let* ((trudst (make-pathname
    2885                                    :defaults (if dst (resolve-location dst t) trusrc)))
     2983                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
    28862984                          (wilddst (make-pathname
    28872985                                    :name :wild :type :wild :version :wild
     
    28902988                     (funcall collect (list trusrc trudst)))))))))))
    28912989
    2892 (defun compute-output-translations (&optional parameter)
     2990(defun* compute-output-translations (&optional parameter)
    28932991  "read the configuration, return it"
    28942992  (remove-duplicates
     
    28982996   :test 'equal :from-end t))
    28992997
    2900 (defun initialize-output-translations (&optional parameter)
     2998(defun* initialize-output-translations (&optional parameter)
    29012999  "read the configuration, initialize the internal configuration variable,
    29023000return the configuration"
    29033001  (setf (output-translations) (compute-output-translations parameter)))
    29043002
    2905 (defun disable-output-translations ()
     3003(defun* disable-output-translations ()
    29063004  "Initialize output translations in a way that maps every file to itself,
    29073005effectively disabling the output translation facility."
     
    29133011;; the latter, initialize.  ASDF will call this function at the start
    29143012;; of (asdf:find-system).
    2915 (defun ensure-output-translations ()
     3013(defun* ensure-output-translations ()
    29163014  (if (output-translations-initialized-p)
    29173015      (output-translations)
    29183016      (initialize-output-translations)))
    29193017
    2920 (defun apply-output-translations (path)
     3018(defun* translate-pathname* (path absolute-source destination &optional root source)
     3019  (declare (ignore source))
     3020  (cond
     3021    ((functionp destination)
     3022     (funcall destination path absolute-source))
     3023    ((eq destination t)
     3024     path)
     3025    ((not (pathnamep destination))
     3026     (error "invalid destination"))
     3027    ((not (absolute-pathname-p destination))
     3028     (translate-pathname path absolute-source (merge-pathnames* destination root)))
     3029    (root
     3030     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
     3031    (t
     3032     (translate-pathname path absolute-source destination))))
     3033
     3034(defun* apply-output-translations (path)
    29213035  (etypecase path
    29223036    (logical-pathname
     
    29353049                                (t source))
    29363050       :when (or (eq source t) (pathname-match-p p absolute-source))
    2937        :return
    2938        (cond
    2939          ((functionp destination)
    2940           (funcall destination p absolute-source))
    2941          ((eq destination t)
    2942           p)
    2943          ((not (pathnamep destination))
    2944           (error "invalid destination"))
    2945          ((not (absolute-pathname-p destination))
    2946           (translate-pathname p absolute-source (merge-pathnames* destination root)))
    2947          (root
    2948           (translate-pathname (directorize-pathname-host-device p) absolute-source destination))
    2949          (t
    2950           (translate-pathname p absolute-source destination)))
     3051       :return (translate-pathname* p absolute-source destination root source)
    29513052       :finally (return p)))))
    29523053
     
    29613062   t))
    29623063
    2963 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
     3064(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
    29643065  (or output-file
    29653066      (apply-output-translations
     
    29683069              keys))))
    29693070
    2970 (defun tmpize-pathname (x)
     3071(defun* tmpize-pathname (x)
    29713072  (make-pathname
    29723073   :name (format nil "ASDF-TMP-~A" (pathname-name x))
    29733074   :defaults x))
    29743075
    2975 (defun delete-file-if-exists (x)
     3076(defun* delete-file-if-exists (x)
    29763077  (when (and x (probe-file x))
    29773078    (delete-file x)))
    29783079
    2979 (defun compile-file* (input-file &rest keys &key &allow-other-keys)
    2980   (let* ((output-file (apply 'compile-file-pathname* input-file keys))
     3080(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
     3081  (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
    29813082         (tmp-file (tmpize-pathname output-file))
    29823083         (status :error))
     
    30023103
    30033104#+abcl
    3004 (defun translate-jar-pathname (source wildcard)
     3105(defun* translate-jar-pathname (source wildcard)
    30053106  (declare (ignore wildcard))
    30063107  (let* ((p (pathname (first (pathname-device source))))
     
    30183119;;;; Compatibility mode for ASDF-Binary-Locations
    30193120
    3020 (defun enable-asdf-binary-locations-compatibility
     3121(defun* enable-asdf-binary-locations-compatibility
    30213122    (&key
    30223123     (centralize-lisp-binaries nil)
     
    30263127                           (user-homedir)))
    30273128     (include-per-user-information nil)
    3028      (map-all-source-files nil)
     3129     (map-all-source-files (or #+(or ecl clisp) t nil))
    30293130     (source-to-target-mappings nil))
     3131  #+(or ecl clisp)
     3132  (when (null map-all-source-files)
     3133    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
    30303134  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
    30313135         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
     
    30543158;;;; http://www.wotsit.org/list.asp?fc=13
    30553159
     3160#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     3161(progn
    30563162(defparameter *link-initial-dword* 76)
    30573163(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
    30583164
    3059 (defun read-null-terminated-string (s)
     3165(defun* read-null-terminated-string (s)
    30603166  (with-output-to-string (out)
    30613167    (loop :for code = (read-byte s)
     
    30633169      :do (write-char (code-char code) out))))
    30643170
    3065 (defun read-little-endian (s &optional (bytes 4))
     3171(defun* read-little-endian (s &optional (bytes 4))
    30663172  (loop
    30673173    :for i :from 0 :below bytes
    30683174    :sum (ash (read-byte s) (* 8 i))))
    30693175
    3070 (defun parse-file-location-info (s)
     3176(defun* parse-file-location-info (s)
    30713177  (let ((start (file-position s))
    30723178        (total-length (read-little-endian s))
     
    30923198          (read-null-terminated-string s))))))
    30933199
    3094 (defun parse-windows-shortcut (pathname)
     3200(defun* parse-windows-shortcut (pathname)
    30953201  (with-open-file (s pathname :element-type '(unsigned-byte 8))
    30963202    (handler-case
     
    31203226                    (map 'string #'code-char buffer)))))))
    31213227      (end-of-file ()
    3122         nil))))
     3228        nil)))))
    31233229
    31243230;;;; -----------------------------------------------------------------
     
    31283234;; Using ack 1.2 exclusions
    31293235(defvar *default-source-registry-exclusions*
    3130   '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
     3236  '(".bzr" ".cdv"
     3237    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
    31313238    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    3132     "_sgbak" "autom4te.cache" "cover_db" "_build"))
     3239    "_sgbak" "autom4te.cache" "cover_db" "_build"
     3240    "debian")) ;; debian often build stuff under the debian directory... BAD.
    31333241
    31343242(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     
    31383246said element itself being a list of directory pathnames where to look for .asd files")
    31393247
    3140 (defun source-registry ()
     3248(defun* source-registry ()
    31413249  (car *source-registry*))
    31423250
    3143 (defun (setf source-registry) (new-value)
     3251(defun* (setf source-registry) (new-value)
    31443252  (setf *source-registry* (list new-value))
    31453253  new-value)
    31463254
    3147 (defun source-registry-initialized-p ()
     3255(defun* source-registry-initialized-p ()
    31483256  (and *source-registry* t))
    31493257
    3150 (defun clear-source-registry ()
     3258(defun* clear-source-registry ()
    31513259  "Undoes any initialization of the source registry.
    31523260You might want to call that before you dump an image that would be resumed
     
    31553263  (values))
    31563264
    3157 (defun validate-source-registry-directive (directive)
     3265(defparameter *wild-asd*
     3266  (make-pathname :directory nil :name :wild :type "asd" :version :newest))
     3267
     3268(defun directory-has-asd-files-p (directory)
     3269  (and (ignore-errors
     3270         (directory (merge-pathnames* *wild-asd* directory)
     3271                    #+sbcl #+sbcl :resolve-symlinks nil
     3272                    #+ccl #+ccl :follow-links nil
     3273                    #+clisp #+clisp :circle t))
     3274       t))
     3275
     3276(defun subdirectories (directory)
     3277  (let* ((directory (ensure-directory-pathname directory))
     3278         #-cormanlisp
     3279         (wild (merge-pathnames*
     3280                #-(or abcl allegro lispworks scl)
     3281                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
     3282                #+(or abcl allegro lispworks scl) "*.*"
     3283                directory))
     3284         (dirs
     3285          #-cormanlisp
     3286          (ignore-errors
     3287            (directory wild .
     3288              #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
     3289                    #+ccl '(:follow-links nil :directories t :files nil)
     3290                    #+clisp '(:circle t :if-does-not-exist :ignore)
     3291                    #+(or cmu scl) '(:follow-links nil :truenamep nil)
     3292                    #+digitool '(:directories t)
     3293                    #+sbcl '(:resolve-symlinks nil))))
     3294          #+cormanlisp (cl::directory-subdirs directory))
     3295         #+(or abcl allegro lispworks scl)
     3296         (dirs (remove-if-not #+abcl #'extensions:probe-directory
     3297                              #+allegro #'excl:probe-directory
     3298                              #+lispworks #'lw:file-directory-p
     3299                              #-(or abcl allegro lispworks) #'directory-pathname-p
     3300                              dirs)))
     3301    dirs))
     3302
     3303(defun collect-sub*directories (directory collectp recursep collector)
     3304  (when (funcall collectp directory)
     3305    (funcall collector directory))
     3306  (dolist (subdir (subdirectories directory))
     3307    (when (funcall recursep subdir)
     3308      (collect-sub*directories subdir collectp recursep collector))))
     3309
     3310(defun collect-sub*directories-with-asd
     3311    (directory &key
     3312     (exclude *default-source-registry-exclusions*)
     3313     collect)
     3314  (collect-sub*directories
     3315   directory
     3316   #'directory-has-asd-files-p
     3317   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
     3318   collect))
     3319
     3320(defun* validate-source-registry-directive (directive)
    31583321  (unless
    31593322      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
     
    31623325              ((:include :directory :tree)
    31633326               (and (length=n-p rest 1)
    3164                     (typep (car rest) '(or pathname string null))))
     3327                    (location-designator-p (first rest))))
    31653328              ((:exclude :also-exclude)
    31663329               (every #'stringp rest))
     
    31693332  directive)
    31703333
    3171 (defun validate-source-registry-form (form)
     3334(defun* validate-source-registry-form (form)
    31723335  (validate-configuration-form
    31733336   form :source-registry 'validate-source-registry-directive "a source registry"))
    31743337
    3175 (defun validate-source-registry-file (file)
     3338(defun* validate-source-registry-file (file)
    31763339  (validate-configuration-file
    31773340   file 'validate-source-registry-form "a source registry"))
    31783341
    3179 (defun validate-source-registry-directory (directory)
     3342(defun* validate-source-registry-directory (directory)
    31803343  (validate-configuration-directory
    31813344   directory :source-registry 'validate-source-registry-directive))
    31823345
    3183 (defun parse-source-registry-string (string)
     3346(defun* parse-source-registry-string (string)
    31843347  (cond
    31853348    ((or (null string) (equal string ""))
     
    32153378           (return `(:source-registry ,@(nreverse directives))))))))))
    32163379
    3217 (defun register-asd-directory (directory &key recurse exclude collect)
     3380(defun* register-asd-directory (directory &key recurse exclude collect)
    32183381  (if (not recurse)
    32193382      (funcall collect directory)
    3220       (let* ((files
    3221               (handler-case
    3222                   (directory (merge-pathnames* *wild-asd* directory)
    3223                              #+sbcl #+sbcl :resolve-symlinks nil
    3224                              #+clisp #+clisp :circle t)
    3225                 (error (c)
    3226                   (warn "Error while scanning system definitions under directory ~S:~%~A"
    3227                         directory c)
    3228                   nil)))
    3229              (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
    3230                                       :test #'equal :from-end t)))
    3231         (loop
    3232           :for dir :in dirs
    3233           :unless (loop :for x :in exclude
    3234                     :thereis (find x (pathname-directory dir) :test #'equal))
    3235           :do (funcall collect dir)))))
     3383      (collect-sub*directories-with-asd
     3384       directory :exclude exclude :collect collect)))
    32363385
    32373386(defparameter *default-source-registries*
     
    32463395(defparameter *source-registry-directory* #p"source-registry.conf.d/")
    32473396
    3248 (defun wrapping-source-registry ()
     3397(defun* wrapping-source-registry ()
    32493398  `(:source-registry
    32503399    #+sbcl (:tree ,(getenv "SBCL_HOME"))
    32513400    :inherit-configuration
    32523401    #+cmu (:tree #p"modules:")))
    3253 (defun default-source-registry ()
     3402(defun* default-source-registry ()
    32543403  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    32553404    `(:source-registry
     
    32773426           :collect `(:tree ,(try dir "common-lisp/source/"))))
    32783427      :inherit-configuration)))
    3279 (defun user-source-registry ()
     3428(defun* user-source-registry ()
    32803429  (in-user-configuration-directory *source-registry-file*))
    3281 (defun system-source-registry ()
     3430(defun* system-source-registry ()
    32823431  (in-system-configuration-directory *source-registry-file*))
    3283 (defun user-source-registry-directory ()
     3432(defun* user-source-registry-directory ()
    32843433  (in-user-configuration-directory *source-registry-directory*))
    3285 (defun system-source-registry-directory ()
     3434(defun* system-source-registry-directory ()
    32863435  (in-system-configuration-directory *source-registry-directory*))
    3287 (defun environment-source-registry ()
     3436(defun* environment-source-registry ()
    32883437  (getenv "CL_SOURCE_REGISTRY"))
    32893438
    3290 (defgeneric process-source-registry (spec &key inherit register))
     3439(defgeneric* process-source-registry (spec &key inherit register))
    32913440(declaim (ftype (function (t &key (:register (or symbol function))) t)
    32923441                inherit-source-registry))
     
    33173466      (process-source-registry-directive directive :inherit inherit :register register))))
    33183467
    3319 (defun inherit-source-registry (inherit &key register)
     3468(defun* inherit-source-registry (inherit &key register)
    33203469  (when inherit
    33213470    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
    33223471
    3323 (defun process-source-registry-directive (directive &key inherit register)
     3472(defun* process-source-registry-directive (directive &key inherit register)
    33243473  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
    33253474    (ecase kw
    33263475      ((:include)
    33273476       (destructuring-bind (pathname) rest
    3328          (process-source-registry (pathname pathname) :inherit nil :register register)))
     3477         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
    33293478      ((:directory)
    33303479       (destructuring-bind (pathname) rest
    33313480         (when pathname
    3332            (funcall register (ensure-directory-pathname pathname)))))
     3481           (funcall register (resolve-location pathname :directory t)))))
    33333482      ((:tree)
    33343483       (destructuring-bind (pathname) rest
    33353484         (when pathname
    3336            (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
     3485           (funcall register (resolve-location pathname :directory t)
     3486                    :recurse t :exclude *source-registry-exclusions*))))
    33373487      ((:exclude)
    33383488       (setf *source-registry-exclusions* rest))
     
    33473497  nil)
    33483498
    3349 (defun flatten-source-registry (&optional parameter)
     3499(defun* flatten-source-registry (&optional parameter)
    33503500  (remove-duplicates
    33513501   (while-collecting (collect)
     
    33603510;; Will read the configuration and initialize all internal variables,
    33613511;; and return the new configuration.
    3362 (defun compute-source-registry (&optional parameter)
     3512(defun* compute-source-registry (&optional parameter)
    33633513  (while-collecting (collect)
    33643514    (dolist (entry (flatten-source-registry parameter))
     
    33683518         :recurse recurse :exclude exclude :collect #'collect)))))
    33693519
    3370 (defun initialize-source-registry (&optional parameter)
     3520(defun* initialize-source-registry (&optional parameter)
    33713521  (setf (source-registry) (compute-source-registry parameter)))
    33723522
     
    33793529;; you may override the configuration explicitly by calling
    33803530;; initialize-source-registry directly with your parameter.
    3381 (defun ensure-source-registry (&optional parameter)
     3531(defun* ensure-source-registry (&optional parameter)
    33823532  (if (source-registry-initialized-p)
    33833533      (source-registry)
    33843534      (initialize-source-registry parameter)))
    33853535
    3386 (defun sysdef-source-registry-search (system)
     3536(defun* sysdef-source-registry-search (system)
    33873537  (ensure-source-registry)
    33883538  (loop :with name = (coerce-name system)
     
    33913541    :when file :return file))
    33923542
     3543(defun* clear-configuration ()
     3544  (clear-source-registry)
     3545  (clear-output-translations))
     3546
    33933547;;;; -----------------------------------------------------------------
    33943548;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
    33953549;;;;
    3396 #+(or abcl clozure cmu ecl sbcl)
    3397 (progn
    3398   (defun module-provide-asdf (name)
    3399     (handler-bind
    3400         ((style-warning #'muffle-warning)
    3401          (missing-component (constantly nil))
    3402          (error (lambda (e)
    3403                   (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
    3404                           name e))))
    3405       (let* ((*verbose-out* (make-broadcast-stream))
    3406              (system (find-system (string-downcase name) nil)))
    3407         (when system
    3408           (load-system system)
    3409           t))))
    3410   (pushnew 'module-provide-asdf
    3411            #+abcl sys::*module-provider-functions*
    3412            #+clozure ccl:*module-provider-functions*
    3413            #+cmu ext:*module-provider-functions*
    3414            #+ecl si:*module-provider-functions*
    3415            #+sbcl sb-ext:*module-provider-functions*))
     3550(defun* module-provide-asdf (name)
     3551  (handler-bind
     3552      ((style-warning #'muffle-warning)
     3553       (missing-component (constantly nil))
     3554       (error (lambda (e)
     3555                (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
     3556                        name e))))
     3557    (let* ((*verbose-out* (make-broadcast-stream))
     3558           (system (find-system (string-downcase name) nil)))
     3559      (when system
     3560        (load-system system)
     3561        t))))
     3562
     3563#+(or abcl clisp clozure cmu ecl sbcl)
     3564(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
     3565  (when x
     3566    (eval `(pushnew 'module-provide-asdf
     3567            #+abcl sys::*module-provider-functions*
     3568            #+clisp ,x
     3569            #+clozure ccl:*module-provider-functions*
     3570            #+cmu ext:*module-provider-functions*
     3571            #+ecl si:*module-provider-functions*
     3572            #+sbcl sb-ext:*module-provider-functions*))))
     3573
    34163574
    34173575;;;; -------------------------------------------------------------------------
Note: See TracChangeset for help on using the changeset viewer.