Changeset 14252


Ignore:
Timestamp:
Sep 11, 2010, 3:14:46 PM (9 years ago)
Author:
rme
Message:

Update ASDF to 2.008.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r13959 r14252  
    4949
    5050(cl:in-package :cl)
    51 (defpackage :asdf-bootstrap (:use :cl))
    52 (in-package :asdf-bootstrap)
    53 
    54 ;; Implementation-dependent tweaks
     51
    5552(eval-when (:compile-toplevel :load-toplevel :execute)
     53  ;;; make package if it doesn't exist yet.
     54  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
     55  (unless (find-package :asdf)
     56    (make-package :asdf :use '(:cl)))
     57  ;;; Implementation-dependent tweaks
    5658  ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
    5759  #+allegro
     
    5961        (remove "asdf" excl::*autoload-package-name-alist*
    6062                :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))))
     63  #+ecl (require :cmp))
     64
     65(in-package :asdf)
    6666
    6767;;;; Create packages in a way that is compatible with hot-upgrade.
     
    7070
    7171(eval-when (:load-toplevel :compile-toplevel :execute)
     72  (defvar *asdf-version* nil)
     73  (defvar *upgraded-p* nil)
    7274  (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)))
     75          (subseq "VERSION:2.008" (1+ (length "VERSION")))) ; same as 2.128
     76         (existing-asdf (fboundp 'find-system))
     77         (existing-version *asdf-version*)
    7978         (already-there (equal asdf-version existing-version)))
    8079    (unless (and existing-asdf already-there)
    81       #-gcl
    8280      (when existing-asdf
    8381        (format *trace-output*
     
    123121               (when sym
    124122                 (unexport sym package)
    125                  (unintern sym package))))
     123                 (unintern sym package)
     124                 sym)))
    126125           (ensure-unintern (package symbols)
    127              (dolist (sym symbols) (remove-symbol sym package)))
     126             (loop :with packages = (list-all-packages)
     127               :for sym :in symbols
     128               :for removed = (remove-symbol sym package)
     129               :when removed :do
     130               (loop :for p :in packages :do
     131                 (when (eq removed (find-sym sym p))
     132                   (unintern removed p)))))
    128133           (ensure-shadow (package symbols)
    129134             (shadow symbols package))
     
    139144               :when sym :do (fmakunbound sym)))
    140145           (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))))
     146             (let ((formerly-exported-symbols nil)
     147                   (bothly-exported-symbols nil)
     148                   (newly-exported-symbols nil))
     149               (loop :for sym :being :each :external-symbol :in package :do
     150                 (if (member sym export :test 'string-equal)
     151                     (push sym bothly-exported-symbols)
     152                     (push sym formerly-exported-symbols)))
     153               (loop :for sym :in export :do
     154                 (unless (member sym bothly-exported-symbols :test 'string-equal)
     155                   (push sym newly-exported-symbols)))
     156               (loop :for user :in (package-used-by-list package)
     157                 :for shadowing = (package-shadowing-symbols user) :do
     158                 (loop :for new :in newly-exported-symbols
     159                   :for old = (find-sym new user)
     160                   :when (and old (not (member old shadowing)))
     161                   :do (unintern old user)))
     162               (loop :for x :in newly-exported-symbols :do
     163                 (export (intern* x package)))))
    148164           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
    149              (let ((p (ensure-exists name nicknames use)))
     165             (let* ((p (ensure-exists name nicknames use)))
    150166               (ensure-unintern p unintern)
    151167               (ensure-shadow p shadow)
     
    161177                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
    162178                   :fmakunbound ',(append fmakunbound))))
    163           (pkgdcl
    164            :asdf-utilities
    165            :nicknames (#:asdf-extensions)
    166            :use (#:common-lisp)
    167            :unintern (#:split #:make-collector)
    168            :export
    169            (#:absolute-pathname-p
    170             #:aif
    171             #:appendf
    172             #:asdf-message
    173             #:coerce-name
    174             #:directory-pathname-p
    175             #:ends-with
    176             #:ensure-directory-pathname
    177             #:getenv
    178             #:get-uid
    179             #:length=n-p
    180             #:merge-pathnames*
    181             #:pathname-directory-pathname
    182             #:read-file-forms
    183             #:remove-keys
    184             #:remove-keyword
    185             #:resolve-symlinks
    186             #:split-string
    187             #:component-name-to-pathname-components
    188             #:split-name-type
    189             #:system-registered-p
    190             #:truenamize
    191             #:while-collecting))
     179          (let ((u (find-package :asdf-utilities)))
     180            (when u
     181              (ensure-unintern u (loop :for s :being :each :present-symbol :in u :collect s))))
    192182          (pkgdcl
    193183           :asdf
    194            :use (:common-lisp :asdf-utilities)
     184           :use (:common-lisp)
    195185           :redefined-functions
    196186           (#:perform #:explain #:output-files #:operation-done-p
    197187            #:perform-with-restarts #:component-relative-pathname
    198             #:system-source-file #:operate #:find-component)
     188            #:system-source-file #:operate #:find-component #:find-system
     189            #:apply-output-translations #:translate-pathname*)
    199190           :unintern
    200191           (#:*asdf-revision* #:around #:asdf-method-combination
     
    208199           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
    209200            #:system-definition-pathname #:find-component ; miscellaneous
    210             #:compile-system #:load-system #:test-system
     201            #:compile-system #:load-system #:test-system #:clear-system
    211202            #:compile-op #:load-op #:load-source-op
    212203            #:test-op
     
    216207            #:version-satisfies
    217208
    218             #:input-files #:output-files #:perform ; operation methods
     209            #:input-files #:output-files #:output-file #:perform ; operation methods
    219210            #:operation-done-p #:explain
    220211
     
    255246            #:operation-on-warnings
    256247            #:operation-on-failure
     248            #:component-visited-p
    257249            ;;#:*component-parent-pathname*
    258250            #:*system-definition-search-functions*
     
    284276            #:remove-entry-from-registry
    285277
     278            #:clear-configuration
    286279            #:initialize-output-translations
    287280            #:disable-output-translations
     
    292285            #:compile-file-pathname*
    293286            #:enable-asdf-binary-locations-compatibility
    294 
    295287            #:*default-source-registries*
    296288            #:initialize-source-registry
     
    298290            #:clear-source-registry
    299291            #: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)
     292            #:process-source-registry
     293            #:system-registered-p
     294            #:asdf-message
     295
     296            ;; Utilities
     297            #:absolute-pathname-p
     298            ;; #:aif #:it
     299            ;; #:appendf
     300            #:coerce-name
     301            #:directory-pathname-p
     302            ;; #:ends-with
     303            #:ensure-directory-pathname
     304            #:getenv
     305            ;; #:get-uid
     306            ;; #:length=n-p
     307            #:merge-pathnames*
     308            #:pathname-directory-pathname
     309            #:read-file-forms
     310            ;; #:remove-keys
     311            ;; #:remove-keyword
     312            #:resolve-symlinks
     313            #:split-string
     314            #:component-name-to-pathname-components
     315            #:split-name-type
     316            #:truenamize
     317            #:while-collecting)))
     318        (setf *asdf-version* asdf-version
     319              *upgraded-p* (if existing-version
     320                               (cons existing-version *upgraded-p*)
     321                               *upgraded-p*))))))
    310322
    311323;; 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))
    316324(when *upgraded-p*
    317325   #+ecl
     
    343351  "Determine whether or not ASDF resolves symlinks when defining systems.
    344352
    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.")
     353Defaults to T.")
     354
     355(defvar *compile-file-warnings-behaviour*
     356  (or #+clisp :ignore :warn)
     357  "How should ASDF react if it encounters a warning when compiling a file?
     358Valid values are :error, :warn, and :ignore.")
     359
     360(defvar *compile-file-failure-behaviour*
     361  (or #+sbcl :error #+clisp :ignore :warn)
     362  "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
     363when compiling a file?  Valid values are :error, :warn, and :ignore.
     364Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
    356365
    357366(defvar *verbose-out* nil)
     
    372381;;;; -------------------------------------------------------------------------
    373382;;;; 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 
     383(macrolet
     384    ((defdef (def* def)
     385       `(defmacro ,def* (name formals &rest rest)
     386          `(progn
     387             #+(or ecl gcl) (fmakunbound ',name)
     388             ,(when (and #+ecl (symbolp name))
     389                `(declaim (notinline ,name))) ; fails for setf functions on ecl
     390             (,',def ,name ,formals ,@rest)))))
     391  (defdef defgeneric* defgeneric)
     392  (defdef defun* defun))
     393
     394(defgeneric* find-system (system &optional error-p))
    379395(defgeneric* perform-with-restarts (operation component))
    380396(defgeneric* perform (operation component))
     
    383399(defgeneric* output-files (operation component))
    384400(defgeneric* input-files (operation component))
    385 (defgeneric component-operation-time (operation component))
     401(defgeneric* component-operation-time (operation component))
     402(defgeneric* operation-description (operation component)
     403  (:documentation "returns a phrase that describes performing this operation
     404on this component, e.g. \"loading /a/b/c\".
     405You can put together sentences using this phrase."))
    386406
    387407(defgeneric* system-source-file (system)
    388408  (:documentation "Return the source file in which system is defined."))
    389409
    390 (defgeneric component-system (component)
     410(defgeneric* component-system (component)
    391411  (:documentation "Find the top-level system containing COMPONENT"))
    392412
    393 (defgeneric component-pathname (component)
     413(defgeneric* component-pathname (component)
    394414  (:documentation "Extracts the pathname applicable for a particular component."))
    395415
    396 (defgeneric component-relative-pathname (component)
     416(defgeneric* component-relative-pathname (component)
    397417  (:documentation "Returns a pathname for the component argument intended to be
    398418interpreted relative to the pathname of that component's parent.
     
    401421another pathname in a degenerate way."))
    402422
    403 (defgeneric component-property (component property))
    404 
    405 (defgeneric (setf component-property) (new-value component property))
    406 
    407 (defgeneric version-satisfies (component version))
     423(defgeneric* component-property (component property))
     424
     425(defgeneric* (setf component-property) (new-value component property))
     426
     427(defgeneric* version-satisfies (component version))
    408428
    409429(defgeneric* find-component (base path)
     
    411431if BASE is nil, then the component is assumed to be a system."))
    412432
    413 (defgeneric source-file-type (component system))
    414 
    415 (defgeneric operation-ancestor (operation)
     433(defgeneric* source-file-type (component system))
     434
     435(defgeneric* operation-ancestor (operation)
    416436  (:documentation
    417437   "Recursively chase the operation's parent pointer until we get to
    418438the head of the tree"))
    419439
    420 (defgeneric component-visited-p (operation component)
     440(defgeneric* component-visited-p (operation component)
    421441  (:documentation "Returns the value stored by a call to
    422442VISIT-COMPONENT, if that has been called, otherwise NIL.
     
    431451operations needed to be performed."))
    432452
    433 (defgeneric visit-component (operation component data)
     453(defgeneric* visit-component (operation component data)
    434454  (:documentation "Record DATA as being associated with OPERATION
    435455and COMPONENT.  This is a side-effecting function:  the association
     
    439459non-NIL.  Using the data field is probably very risky; if there is
    440460already 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)
     461discarded instead of recorded.
     462  Starting with 2.006, TRAVERSE will store an integer in data,
     463so that nodes can be sorted in decreasing order of traversal."))
     464
     465
     466(defgeneric* (setf visiting-component) (new-value operation component))
     467
     468(defgeneric* component-visiting-p (operation component))
     469
     470(defgeneric* component-depends-on (operation component)
    448471  (:documentation
    449472   "Returns a list of dependencies needed by the component to perform
     
    462485    list."))
    463486
    464 (defgeneric component-self-dependencies (operation component))
    465 
    466 (defgeneric traverse (operation component)
     487(defgeneric* component-self-dependencies (operation component))
     488
     489(defgeneric* traverse (operation component)
    467490  (:documentation
    468491"Generate and return a plan for performing OPERATION on COMPONENT.
     
    497520  `(let ((it ,test)) (if it ,then ,else)))
    498521
    499 (defun pathname-directory-pathname (pathname)
     522(defun* pathname-directory-pathname (pathname)
    500523  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    501524and NIL NAME, TYPE and VERSION components"
     
    503526    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    504527
    505 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     528(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    506529  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
    507530does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
     
    512535         (defaults (pathname defaults))
    513536         (directory (pathname-directory specified))
    514          #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
     537         #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory))
    515538         (name (or (pathname-name specified) (pathname-name defaults)))
    516539         (type (or (pathname-type specified) (pathname-type defaults)))
     
    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 &optional force-directory)
    602625  "Splits the path string S, returning three values:
    603626A flag that is either :absolute or :relative, indicating
     
    633656         (values relative (butlast components) last-comp))))))
    634657
    635 (defun remove-keys (key-names args)
     658(defun* remove-keys (key-names args)
    636659  (loop :for (name val) :on args :by #'cddr
    637660    :unless (member (symbol-name name) key-names
     
    639662    :append (list name val)))
    640663
    641 (defun remove-keyword (key args)
     664(defun* remove-keyword (key args)
    642665  (loop :for (k v) :on args :by #'cddr
    643666    :unless (eq k key)
    644667    :append (list k v)))
    645668
    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)
     669(defun* getenv (x)
     670  (#+abcl ext:getenv
     671   #+allegro sys:getenv
     672   #+clisp ext:getenv
     673   #+clozure ccl:getenv
     674   #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
     675   #+ecl si:getenv
     676   #+gcl system:getenv
     677   #+lispworks lispworks:environment-variable
     678   #+sbcl sb-ext:posix-getenv
     679   x))
     680
     681(defun* directory-pathname-p (pathname)
    667682  "Does PATHNAME represent a directory?
    668683
     
    679694         t)))
    680695
    681 (defun ensure-directory-pathname (pathspec)
     696(defun* ensure-directory-pathname (pathspec)
    682697  "Converts the non-wild pathname designator PATHSPEC to directory form."
    683698  (cond
     
    697712                   :defaults pathspec))))
    698713
    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) ?
     714(defun* absolute-pathname-p (pathspec)
     715  (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
     716
     717(defun* length=n-p (x n) ;is it that (= (length x) n) ?
    703718  (check-type n (integer 0 *))
    704719  (loop
     
    709724      ((not (consp l)) (return nil)))))
    710725
    711 (defun ends-with (s suffix)
     726(defun* ends-with (s suffix)
    712727  (check-type s string)
    713728  (check-type suffix string)
     
    716731         (string-equal s suffix :start1 start))))
    717732
    718 (defun read-file-forms (file)
     733(defun* read-file-forms (file)
    719734  (with-open-file (in file)
    720735    (loop :with eof = (list nil)
     
    725740#-(and (or win32 windows mswindows mingw32) (not cygwin))
    726741(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)
     742  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
     743                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
     744  (defun* get-uid ()
     745    #+allegro (excl.osi:getuid)
     746    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
     747                  :for f = (ignore-errors (read-from-string s))
     748                  :when f :return (funcall f))
     749    #+(or cmu scl) (unix:unix-getuid)
     750    #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
     751                   '(ffi:c-inline () () :int "getuid()" :one-liner t)
     752                   '(ext::getuid))
     753    #+sbcl (sb-unix:unix-getuid)
     754    #-(or allegro clisp cmu ecl sbcl scl)
     755    (let ((uid-string
     756           (with-output-to-string (*verbose-out*)
     757             (run-shell-command "id -ur"))))
     758      (with-input-from-string (stream uid-string)
     759        (read-line stream)
     760        (handler-case (parse-integer (read-line stream))
     761          (error () (error "Unable to find out user ID")))))))
     762
     763(defun* pathname-root (pathname)
    748764  (make-pathname :host (pathname-host pathname)
    749765                 :device (pathname-device pathname)
     
    751767                 :name nil :type nil :version nil))
    752768
    753 (defun truenamize (p)
     769(defun* probe-file* (p)
     770  "when given a pathname P, probes the filesystem for a file or directory
     771with given pathname and if it exists return its truename."
     772  (etypecase p
     773   (null nil)
     774   (string (probe-file* (parse-namestring p)))
     775   (pathname (unless (wild-pathname-p p)
     776               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
     777               #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p))
     778               '(ignore-errors (truename p)))))))
     779
     780(defun* truenamize (p)
    754781  "Resolve as much of a pathname as possible"
    755782  (block nil
     
    758785           (directory (pathname-directory p)))
    759786      (when (typep p 'logical-pathname) (return p))
    760       (ignore-errors (return (truename p)))
    761       #-sbcl (when (stringp directory) (return p))
     787      (let ((found (probe-file* p)))
     788        (when found (return found)))
     789      #-(or sbcl cmu) (when (stringp directory) (return p))
    762790      (when (not (eq :absolute (car directory))) (return p))
    763       (let ((sofar (ignore-errors (truename (pathname-root p)))))
     791      (let ((sofar (probe-file* (pathname-root p))))
    764792        (unless sofar (return p))
    765793        (flet ((solution (directories)
     
    773801          (loop :for component :in (cdr directory)
    774802            :for rest :on (cdr directory)
    775             :for more = (ignore-errors
    776                           (truename
    777                            (merge-pathnames*
    778                             (make-pathname :directory `(:relative ,component))
    779                             sofar))) :do
     803            :for more = (probe-file*
     804                         (merge-pathnames*
     805                          (make-pathname :directory `(:relative ,component))
     806                          sofar)) :do
    780807            (if more
    781808                (setf sofar more)
     
    784811            (return (solution nil))))))))
    785812
    786 (defun resolve-symlinks (path)
     813(defun* resolve-symlinks (path)
    787814  #-allegro (truenamize path)
    788815  #+allegro (excl:pathname-resolve-symbolic-links path))
    789816
    790 (defun default-directory ()
     817(defun* default-directory ()
    791818  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
    792819
    793 (defun lispize-pathname (input-file)
     820(defun* lispize-pathname (input-file)
    794821  (make-pathname :type "lisp" :defaults input-file))
    795822
     
    798825                 :name :wild :type :wild :version :wild))
    799826
    800 (defun wilden (path)
     827(defun* wilden (path)
    801828  (merge-pathnames* *wild-path* path))
    802829
    803 (defun directorize-pathname-host-device (pathname)
     830(defun* directorize-pathname-host-device (pathname)
    804831  (let* ((root (pathname-root pathname))
    805832         (wild-root (wilden root))
     
    838865                duplicate-names-name
    839866                error-component error-operation
    840                 module-components module-components-by-name)
     867                module-components module-components-by-name
     868                circular-dependency-components)
    841869         (ftype (function (t t) t) (setf module-components-by-name)))
    842870
     
    857885
    858886(define-condition circular-dependency (system-definition-error)
    859   ((components :initarg :components :reader circular-dependency-components)))
     887  ((components :initarg :components :reader circular-dependency-components))
     888  (:report (lambda (c s)
     889             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
    860890
    861891(define-condition duplicate-names (system-definition-error)
     
    896926                :accessor component-in-order-to)
    897927   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
     928   ;; POIU is a parallel (multi-process build) extension of ASDF.  See
     929   ;; http://www.cliki.net/poiu
    898930   (load-dependencies :accessor component-load-dependencies :initform nil)
    899931   ;; XXX crap name, but it's an official API name!
     
    916948               :initform nil)))
    917949
    918 (defun component-find-path (component)
     950(defun* component-find-path (component)
    919951  (reverse
    920952   (loop :for c = component :then (component-parent c)
     
    932964          (call-next-method c nil) (missing-required-by c)))
    933965
    934 (defun sysdef-error (format &rest arguments)
     966(defun* sysdef-error (format &rest arguments)
    935967  (error 'formatted-system-definition-error :format-control
    936968         format :format-arguments arguments))
     
    939971
    940972(defmethod print-object ((c missing-component) s)
    941    (format s "~@<component ~S not found~
     973  (format s "~@<component ~S not found~
    942974             ~@[ in ~A~]~@:>"
    943975          (missing-requires c)
     
    948980  (format s "~@<component ~S does not match version ~A~
    949981              ~@[ in ~A~]~@:>"
    950            (missing-requires c)
    951            (missing-version c)
    952            (when (missing-parent c)
    953              (component-name (missing-parent c)))))
     982          (missing-requires c)
     983          (missing-version c)
     984          (when (missing-parent c)
     985            (component-name (missing-parent c)))))
    954986
    955987(defmethod component-system ((component component))
     
    960992(defvar *default-component-class* 'cl-source-file)
    961993
    962 (defun compute-module-components-by-name (module)
     994(defun* compute-module-components-by-name (module)
    963995  (let ((hash (make-hash-table :test 'equal)))
    964996    (setf (module-components-by-name module) hash)
     
    9901022    :accessor module-default-component-class)))
    9911023
    992 (defun component-parent-pathname (component)
     1024(defun* component-parent-pathname (component)
    9931025  ;; No default anymore (in particular, no *default-pathname-defaults*).
    9941026  ;; If you force component to have a NULL pathname, you better arrange
     
    10071039             (pathname-directory-pathname (component-parent-pathname component)))))
    10081040        (unless (or (null pathname) (absolute-pathname-p pathname))
    1009           (error "Invalid relative pathname ~S for component ~S" pathname component))
     1041          (error "Invalid relative pathname ~S for component ~S"
     1042                 pathname (component-find-path component)))
    10101043        (setf (slot-value component 'absolute-pathname) pathname)
    10111044        pathname)))
     
    10581091;;;; Finding systems
    10591092
    1060 (defun make-defined-systems-table ()
     1093(defun* make-defined-systems-table ()
    10611094  (make-hash-table :test 'equal))
    10621095
     
    10681101of which is a system object.")
    10691102
    1070 (defun coerce-name (name)
     1103(defun* coerce-name (name)
    10711104  (typecase name
    10721105    (component (component-name name))
     
    10751108    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
    10761109
    1077 (defun system-registered-p (name)
     1110(defun* system-registered-p (name)
    10781111  (gethash (coerce-name name) *defined-systems*))
    10791112
    1080 (defun clear-system (name)
     1113(defun* clear-system (name)
    10811114  "Clear the entry for a system in the database of systems previously loaded.
    10821115Note that this does NOT in any way cause the code of the system to be unloaded."
     
    10891122  (setf (gethash (coerce-name name) *defined-systems*) nil))
    10901123
    1091 (defun map-systems (fn)
     1124(defun* map-systems (fn)
    10921125  "Apply FN to each defined system.
    10931126
     
    11071140  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    11081141
    1109 (defun system-definition-pathname (system)
     1142(defun* system-definition-pathname (system)
    11101143  (let ((system-name (coerce-name system)))
    11111144    (or
     
    11311164")
    11321165
    1133 (defun probe-asd (name defaults)
     1166(defun* probe-asd (name defaults)
    11341167  (block nil
    11351168    (when (directory-pathname-p defaults)
     
    11521185              (return (pathname target)))))))))
    11531186
    1154 (defun sysdef-central-registry-search (system)
     1187(defun* sysdef-central-registry-search (system)
    11551188  (let ((name (coerce-name system))
    11561189        (to-remove nil)
     
    11941227                          (subseq *central-registry* (1+ position))))))))))
    11951228
    1196 (defun make-temporary-package ()
     1229(defun* make-temporary-package ()
    11971230  (flet ((try (counter)
    11981231           (ignore-errors
     
    12031236         (package package))))
    12041237
    1205 (defun safe-file-write-date (pathname)
     1238(defun* safe-file-write-date (pathname)
    12061239  ;; If FILE-WRITE-DATE returns NIL, it's possible that
    12071240  ;; the user or some other agent has deleted an input file.
     
    12141247  (or (and pathname (probe-file pathname) (file-write-date pathname))
    12151248      (progn
    1216         (when pathname
     1249        (when (and pathname *asdf-verbose*)
    12171250          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
    12181251                pathname))
    12191252        0)))
    12201253
    1221 (defun find-system (name &optional (error-p t))
     1254(defmethod find-system (name &optional (error-p t))
     1255  (find-system (coerce-name name) error-p))
     1256
     1257(defmethod find-system ((name string) &optional (error-p t))
    12221258  (catch 'find-system
    1223     (let* ((name (coerce-name name))
    1224            (in-memory (system-registered-p name))
     1259    (let* ((in-memory (system-registered-p name))
    12251260           (on-disk (system-definition-pathname name)))
    12261261      (when (and on-disk
     
    12411276            (delete-package package))))
    12421277      (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)
     1278        (cond
     1279          (in-memory
     1280           (when on-disk
     1281             (setf (car in-memory) (safe-file-write-date on-disk)))
     1282           (cdr in-memory))
     1283          (error-p
     1284           (error 'missing-component :requires name)))))))
     1285
     1286(defun* register-system (name system)
    12501287  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    12511288  (setf (gethash (coerce-name name) *defined-systems*)
    12521289        (cons (get-universal-time) system)))
    12531290
    1254 (defun sysdef-find-asdf (system)
     1291(defun* sysdef-find-asdf (system)
    12551292  (let ((name (coerce-name system)))
    12561293    (when (equal name "asdf")
     
    13181355  (source-file-explicit-type component))
    13191356
    1320 (defun merge-component-name-type (name &key type defaults)
     1357(defun* merge-component-name-type (name &key type defaults)
    13211358  ;; The defaults are required notably because they provide the default host
    13221359  ;; to the below make-pathname, which may crucially matter to people using
     
    13251362  ;; but that should only matter if you either (a) use absolute pathnames, or
    13261363  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
    1327   ;; ASDF-UTILITIES:MERGE-PATHNAMES*
     1364  ;; ASDF:MERGE-PATHNAMES*
    13281365  (etypecase name
    13291366    (pathname
     
    13701407   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    13711408   ;;   to force systems named in a given list
    1372    ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
     1409   ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
    13731410   (forced :initform nil :initarg :force :accessor operation-forced)
    13741411   (original-initargs :initform nil :initarg :original-initargs
     
    13901427  (values))
    13911428
    1392 (defun node-for (o c)
     1429(defun* node-for (o c)
    13931430  (cons (class-name (class-of o)) c))
    13941431
     
    13991436
    14001437
    1401 (defun make-sub-operation (c o dep-c dep-o)
     1438(defun* make-sub-operation (c o dep-c dep-o)
    14021439  "C is a component, O is an operation, DEP-C is another
    14031440component, and DEP-O, confusingly enough, is an operation
     
    15441581recursive calls to traverse.")
    15451582
    1546 (defgeneric do-traverse (operation component collect))
    1547 
    1548 (defun %do-one-dep (operation c collect required-op required-c required-v)
     1583(defgeneric* do-traverse (operation component collect))
     1584
     1585(defun* %do-one-dep (operation c collect required-op required-c required-v)
    15491586  ;; collects a partial plan that results from performing required-op
    15501587  ;; on required-c, possibly with a required-vERSION
     
    15621599    (do-traverse op dep-c collect)))
    15631600
    1564 (defun do-one-dep (operation c collect required-op required-c required-v)
     1601(defun* do-one-dep (operation c collect required-op required-c required-v)
    15651602  ;; this function is a thin, error-handling wrapper around
    15661603  ;; %do-one-dep.  Returns a partial plan per that function.
     
    15721609        :report (lambda (s)
    15731610                  (format s "~@<Retry loading component ~S.~@:>"
    1574                           required-c))
     1611                          (component-find-path required-c)))
    15751612        :test
    15761613        (lambda (c)
     
    15871624                           required-c))))))))
    15881625
    1589 (defun do-dep (operation c collect op dep)
     1626(defun* do-dep (operation c collect op dep)
    15901627  ;; type of arguments uncertain:
    15911628  ;; op seems to at least potentially be a symbol, rather than an operation
     
    16261663           flag))))
    16271664
    1628 (defun do-collect (collect x)
     1665(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
     1666
     1667(defun* do-collect (collect x)
    16291668  (funcall collect x))
    16301669
     
    17111750                 (do-collect collect (cons operation c)))))
    17121751             (setf (visiting-component operation c) nil)))
    1713       (visit-component operation c flag)
     1752      (visit-component operation c (when flag (incf *visit-count*)))
    17141753      flag))
    17151754
    1716 (defun flatten-tree (l)
     1755(defun* flatten-tree (l)
    17171756  ;; You collected things into a list.
    17181757  ;; Most elements are just things to collect again.
     
    17411780  (flatten-tree
    17421781   (while-collecting (collect)
    1743      (do-traverse operation c #'collect))))
     1782     (let ((*visit-count* 0))
     1783       (do-traverse operation c #'collect)))))
    17441784
    17451785(defmethod perform ((operation operation) (c source-file))
     
    17541794
    17551795(defmethod explain ((operation operation) (component component))
    1756   (asdf-message "~&;;; ~A on ~A~%" operation component))
     1796  (asdf-message "~&;;; ~A~%" (operation-description operation component)))
     1797
     1798(defmethod operation-description (operation component)
     1799  (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
    17571800
    17581801;;;; -------------------------------------------------------------------------
     
    17681811          :initform #-ecl nil #+ecl '(:system-p t))))
    17691812
     1813(defun output-file (operation component)
     1814  "The unique output file of performing OPERATION on COMPONENT"
     1815  (let ((files (output-files operation component)))
     1816    (assert (length=n-p files 1))
     1817    (first files)))
     1818
    17701819(defmethod perform :before ((operation compile-op) (c source-file))
    17711820  (map nil #'ensure-directories-exist (output-files operation c)))
     
    17931842  #-:broken-fasl-loader
    17941843  (let ((source-file (component-pathname c))
    1795         (output-file (car (output-files operation c)))
     1844        ;; on some implementations, there are more than one output-file,
     1845        ;; but the first one should always be the primary fasl that gets loaded.
     1846        (output-file (first (output-files operation c)))
    17961847        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
    17971848        (*compile-file-failure-behaviour* (operation-on-failure operation)))
     
    18361887  nil)
    18371888
     1889(defmethod operation-description ((operation compile-op) component)
     1890  (declare (ignorable operation))
     1891  (format nil "compiling component ~S" (component-find-path component)))
    18381892
    18391893;;;; -------------------------------------------------------------------------
     
    19121966        (call-next-method)))
    19131967
     1968(defmethod operation-description ((operation load-op) component)
     1969  (declare (ignorable operation))
     1970  (format nil "loading component ~S" (component-find-path component)))
     1971
     1972
    19141973;;;; -------------------------------------------------------------------------
    19151974;;;; load-source-op
     
    19492008             (component-property c 'last-loaded-as-source)))
    19502009      nil t))
     2010
     2011(defmethod operation-description ((operation load-source-op) component)
     2012  (declare (ignorable operation))
     2013  (format nil "loading component ~S" (component-find-path component)))
    19512014
    19522015
     
    19992062                :report
    20002063                (lambda (s)
    2001                   (format s "~@<Retry performing ~S on ~S.~@:>"
    2002                           op component)))
     2064                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
    20032065              (accept ()
    20042066                :report
    20052067                (lambda (s)
    2006                   (format s "~@<Continue, treating ~S on ~S as ~
     2068                  (format s "~@<Continue, treating ~A as ~
    20072069                                   having been successful.~@:>"
    2008                           op component))
     2070                          (operation-description op component)))
    20092071                (setf (gethash (type-of op)
    20102072                               (component-operation-times component))
    20112073                      (get-universal-time))
    2012                 (return)))))))
    2013     op))
    2014 
    2015 (defun oos (operation-class system &rest args &key force verbose version
     2074                (return))))))
     2075      (values op steps))))
     2076
     2077(defun* oos (operation-class system &rest args &key force verbose version
    20162078            &allow-other-keys)
    20172079  (declare (ignore force verbose version))
     
    20432105        operate-docstring))
    20442106
    2045 (defun load-system (system &rest args &key force verbose version
     2107(defun* load-system (system &rest args &key force verbose version
    20462108                    &allow-other-keys)
    20472109  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
     
    20502112  (apply #'operate 'load-op system args))
    20512113
    2052 (defun compile-system (system &rest args &key force verbose version
     2114(defun* compile-system (system &rest args &key force verbose version
    20532115                       &allow-other-keys)
    20542116  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
     
    20572119  (apply #'operate 'compile-op system args))
    20582120
    2059 (defun test-system (system &rest args &key force verbose version
     2121(defun* test-system (system &rest args &key force verbose version
    20602122                    &allow-other-keys)
    20612123  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
     
    20672129;;;; Defsystem
    20682130
    2069 (defun load-pathname ()
     2131(defun* load-pathname ()
    20702132  (let ((pn (or *load-pathname* *compile-file-pathname*)))
    20712133    (if *resolve-symlinks*
     
    20732135        pn)))
    20742136
    2075 (defun determine-system-pathname (pathname pathname-supplied-p)
     2137(defun* determine-system-pathname (pathname pathname-supplied-p)
    20762138  ;; The defsystem macro calls us to determine
    20772139  ;; the pathname of a system as follows:
     
    20822144         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
    20832145    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
    2084         file-pathname
     2146        directory-pathname
    20852147        (default-directory))))
    20862148
     
    21132175               ',component-options))))))
    21142176
    2115 (defun class-for-type (parent type)
     2177(defun* class-for-type (parent type)
    21162178  (or (loop :for symbol :in (list
    21172179                             (unless (keywordp type) type)
     
    21262188      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
    21272189
    2128 (defun maybe-add-tree (tree op1 op2 c)
     2190(defun* maybe-add-tree (tree op1 op2 c)
    21292191  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
    21302192Returns the new tree (which probably shares structure with the old one)"
     
    21412203        (acons op1 (list (list op2 c)) tree))))
    21422204
    2143 (defun union-of-dependencies (&rest deps)
     2205(defun* union-of-dependencies (&rest deps)
    21442206  (let ((new-tree nil))
    21452207    (dolist (dep deps)
     
    21542216(defvar *serial-depends-on* nil)
    21552217
    2156 (defun sysdef-error-component (msg type name value)
     2218(defun* sysdef-error-component (msg type name value)
    21572219  (sysdef-error (concatenate 'string msg
    21582220                             "~&The value specified for ~(~A~) ~A is ~S")
    21592221                type name value))
    21602222
    2161 (defun check-component-input (type name weakly-depends-on
     2223(defun* check-component-input (type name weakly-depends-on
    21622224                              depends-on components in-order-to)
    21632225  "A partial test of the values of a component."
     
    21752237                            type name in-order-to)))
    21762238
    2177 (defun %remove-component-inline-methods (component)
     2239(defun* %remove-component-inline-methods (component)
    21782240  (dolist (name +asdf-methods+)
    21792241    (map ()
     
    21872249  (setf (component-inline-methods component) nil))
    21882250
    2189 (defun %define-component-inline-methods (ret rest)
     2251(defun* %define-component-inline-methods (ret rest)
    21902252  (dolist (name +asdf-methods+)
    21912253    (let ((keyword (intern (symbol-name name) :keyword)))
     
    22012263           (component-inline-methods ret)))))))
    22022264
    2203 (defun %refresh-component-inline-methods (component rest)
     2265(defun* %refresh-component-inline-methods (component rest)
    22042266  (%remove-component-inline-methods component)
    22052267  (%define-component-inline-methods component rest))
    22062268
    2207 (defun parse-component-form (parent options)
     2269(defun* parse-component-form (parent options)
    22082270  (destructuring-bind
    22092271        (type name &rest rest &key
     
    22862348;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
    22872349
    2288 (defun run-shell-command (control-string &rest args)
     2350(defun* run-shell-command (control-string &rest args)
    22892351  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    22902352synchronously execute the result using a Bourne-compatible shell, with
     
    23582420  (system-source-file (find-system system-name)))
    23592421
    2360 (defun system-source-directory (system-designator)
     2422(defun* system-source-directory (system-designator)
    23612423  "Return a pathname object corresponding to the
    23622424directory in which the system specification (.asd file) is
     
    23662428                 :defaults (system-source-file system-designator)))
    23672429
    2368 (defun relativize-directory (directory)
     2430(defun* relativize-directory (directory)
    23692431  (cond
    23702432    ((stringp directory)
     
    23752437     directory)))
    23762438
    2377 (defun relativize-pathname-directory (pathspec)
     2439(defun* relativize-pathname-directory (pathspec)
    23782440  (let ((p (pathname pathspec)))
    23792441    (make-pathname
     
    23812443     :defaults p)))
    23822444
    2383 (defun system-relative-pathname (system name &key type)
     2445(defun* system-relative-pathname (system name &key type)
    23842446  (merge-pathnames*
    23852447   (merge-component-name-type name :type type)
     
    24122474
    24132475
    2414 (defun lisp-version-string ()
     2476(defun* lisp-version-string ()
    24152477  (let ((s (lisp-implementation-version)))
    24162478    (declare (ignorable s))
     
    24472509          ecl gcl lispworks mcl sbcl scl) s))
    24482510
    2449 (defun first-feature (features)
     2511(defun* first-feature (features)
    24502512  (labels
    24512513      ((fp (thing)
     
    24632525      :when (fp f) :return :it)))
    24642526
    2465 (defun implementation-type ()
     2527(defun* implementation-type ()
    24662528  (first-feature *implementation-features*))
    24672529
    2468 (defun implementation-identifier ()
     2530(defun* implementation-identifier ()
    24692531  (labels
    24702532      ((maybe-warn (value fstring &rest args)
     
    24962558  #-(or unix cygwin) #\;)
    24972559
    2498 (defun user-homedir ()
     2560(defun* user-homedir ()
    24992561  (truename (user-homedir-pathname)))
    25002562
    2501 (defun try-directory-subpath (x sub &key type)
     2563(defun* try-directory-subpath (x sub &key type)
    25022564  (let* ((p (and x (ensure-directory-pathname x)))
    2503          (tp (and p (ignore-errors (truename p))))
     2565         (tp (and p (probe-file* p)))
    25042566         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
    2505          (ts (and sp (ignore-errors (truename sp)))))
     2567         (ts (and sp (probe-file* sp))))
    25062568    (and ts (values sp ts))))
    2507 (defun user-configuration-directories ()
     2569(defun* user-configuration-directories ()
    25082570  (remove-if
    25092571   #'null
     
    25182580           ,(try (getenv "APPDATA") "common-lisp/config/"))
    25192581       ,(try (user-homedir) ".config/common-lisp/")))))
    2520 (defun system-configuration-directories ()
     2582(defun* system-configuration-directories ()
    25212583  (remove-if
    25222584   #'null
     
    25282590        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    25292591    (list #p"/etc/common-lisp/"))))
    2530 (defun in-first-directory (dirs x)
     2592(defun* in-first-directory (dirs x)
    25312593  (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)
     2594    :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
     2595(defun* in-user-configuration-directory (x)
    25352596  (in-first-directory (user-configuration-directories) x))
    2536 (defun in-system-configuration-directory (x)
     2597(defun* in-system-configuration-directory (x)
    25372598  (in-first-directory (system-configuration-directories) x))
    25382599
    2539 (defun configuration-inheritance-directive-p (x)
     2600(defun* configuration-inheritance-directive-p (x)
    25402601  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
    25412602    (or (member x kw)
    25422603        (and (length=n-p x 1) (member (car x) kw)))))
    25432604
    2544 (defun validate-configuration-form (form tag directive-validator
     2605(defun* validate-configuration-form (form tag directive-validator
    25452606                                    &optional (description tag))
    25462607  (unless (and (consp form) (eq (car form) tag))
     
    25572618  form)
    25582619
    2559 (defun validate-configuration-file (file validator description)
     2620(defun* validate-configuration-file (file validator description)
    25602621  (let ((forms (read-file-forms file)))
    25612622    (unless (length=n-p forms 1)
     
    25632624    (funcall validator (car forms))))
    25642625
    2565 (defun hidden-file-p (pathname)
     2626(defun* hidden-file-p (pathname)
    25662627  (equal (first-char (pathname-name pathname)) #\.))
    25672628
    2568 (defun validate-configuration-directory (directory tag validator)
     2629(defun* validate-configuration-directory (directory tag validator)
    25692630  (let ((files (sort (ignore-errors
    25702631                       (remove-if
     
    26042665  *user-cache*)
    26052666
    2606 (defun output-translations ()
     2667(defun* output-translations ()
    26072668  (car *output-translations*))
    26082669
    2609 (defun (setf output-translations) (new-value)
     2670(defun* (setf output-translations) (new-value)
    26102671  (setf *output-translations*
    26112672        (list
     
    26182679  new-value)
    26192680
    2620 (defun output-translations-initialized-p ()
     2681(defun* output-translations-initialized-p ()
    26212682  (and *output-translations* t))
    26222683
    2623 (defun clear-output-translations ()
     2684(defun* clear-output-translations ()
    26242685  "Undoes any initialization of the output translations.
    26252686You might want to call that before you dump an image that would be resumed
     
    26322693                 :name :wild :type "asd" :version :newest))
    26332694
    2634 
    2635 (declaim (ftype (function (t &optional boolean) (or null pathname))
     2695(declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional))
    26362696                resolve-location))
    26372697
    2638 (defun resolve-relative-location-component (super x &optional wildenp)
     2698(defun* resolve-relative-location-component (super x &optional wildenp)
    26392699  (let* ((r (etypecase x
    26402700              (pathname x)
     
    26612721    (merge-pathnames* s super)))
    26622722
    2663 (defun resolve-absolute-location-component (x wildenp)
     2723(defun* resolve-absolute-location-component (x wildenp)
    26642724  (let* ((r
    26652725          (etypecase x
     
    26892749    s))
    26902750
    2691 (defun resolve-location (x &optional wildenp)
     2751(defun* resolve-location (x &optional wildenp)
    26922752  (if (atom x)
    26932753      (resolve-absolute-location-component x wildenp)
     
    26982758        :finally (return path))))
    26992759
    2700 (defun location-designator-p (x)
     2760(defun* location-designator-p (x)
    27012761  (flet ((componentp (c) (typep c '(or string pathname keyword))))
    27022762    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
    27032763
    2704 (defun location-function-p (x)
     2764(defun* location-function-p (x)
    27052765  (and
    27062766   (consp x)
     
    27122772            (length=n-p (second x) 2)))))
    27132773
    2714 (defun validate-output-translations-directive (directive)
     2774(defun* validate-output-translations-directive (directive)
    27152775  (unless
    27162776      (or (member directive '(:inherit-configuration
     
    27292789  directive)
    27302790
    2731 (defun validate-output-translations-form (form)
     2791(defun* validate-output-translations-form (form)
    27322792  (validate-configuration-form
    27332793   form
     
    27362796   "output translations"))
    27372797
    2738 (defun validate-output-translations-file (file)
     2798(defun* validate-output-translations-file (file)
    27392799  (validate-configuration-file
    27402800   file 'validate-output-translations-form "output translations"))
    27412801
    2742 (defun validate-output-translations-directory (directory)
     2802(defun* validate-output-translations-directory (directory)
    27432803  (validate-configuration-directory
    27442804   directory :output-translations 'validate-output-translations-directive))
    27452805
    2746 (defun parse-output-translations-string (string)
     2806(defun* parse-output-translations-string (string)
    27472807  (cond
    27482808    ((or (null string) (equal string ""))
     
    27892849    system-output-translations-directory-pathname))
    27902850
    2791 (defun wrapping-output-translations ()
     2851(defun* wrapping-output-translations ()
    27922852  `(:output-translations
    27932853    ;; Some implementations have precompiled ASDF systems,
     
    28072867(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
    28082868
    2809 (defun user-output-translations-pathname ()
     2869(defun* user-output-translations-pathname ()
    28102870  (in-user-configuration-directory *output-translations-file* ))
    2811 (defun system-output-translations-pathname ()
     2871(defun* system-output-translations-pathname ()
    28122872  (in-system-configuration-directory *output-translations-file*))
    2813 (defun user-output-translations-directory-pathname ()
     2873(defun* user-output-translations-directory-pathname ()
    28142874  (in-user-configuration-directory *output-translations-directory*))
    2815 (defun system-output-translations-directory-pathname ()
     2875(defun* system-output-translations-directory-pathname ()
    28162876  (in-system-configuration-directory *output-translations-directory*))
    2817 (defun environment-output-translations ()
     2877(defun* environment-output-translations ()
    28182878  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
    28192879
    2820 (defgeneric process-output-translations (spec &key inherit collect))
     2880(defgeneric* process-output-translations (spec &key inherit collect))
    28212881(declaim (ftype (function (t &key (:collect (or symbol function))) t)
    28222882                inherit-output-translations))
     
    28482908    (process-output-translations-directive directive :inherit inherit :collect collect)))
    28492909
    2850 (defun inherit-output-translations (inherit &key collect)
     2910(defun* inherit-output-translations (inherit &key collect)
    28512911  (when inherit
    28522912    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
    28532913
    2854 (defun process-output-translations-directive (directive &key inherit collect)
     2914(defun* process-output-translations-directive (directive &key inherit collect)
    28552915  (if (atom directive)
    28562916      (ecase directive
     
    28902950                     (funcall collect (list trusrc trudst)))))))))))
    28912951
    2892 (defun compute-output-translations (&optional parameter)
     2952(defun* compute-output-translations (&optional parameter)
    28932953  "read the configuration, return it"
    28942954  (remove-duplicates
     
    28982958   :test 'equal :from-end t))
    28992959
    2900 (defun initialize-output-translations (&optional parameter)
     2960(defun* initialize-output-translations (&optional parameter)
    29012961  "read the configuration, initialize the internal configuration variable,
    29022962return the configuration"
    29032963  (setf (output-translations) (compute-output-translations parameter)))
    29042964
    2905 (defun disable-output-translations ()
     2965(defun* disable-output-translations ()
    29062966  "Initialize output translations in a way that maps every file to itself,
    29072967effectively disabling the output translation facility."
     
    29132973;; the latter, initialize.  ASDF will call this function at the start
    29142974;; of (asdf:find-system).
    2915 (defun ensure-output-translations ()
     2975(defun* ensure-output-translations ()
    29162976  (if (output-translations-initialized-p)
    29172977      (output-translations)
    29182978      (initialize-output-translations)))
    29192979
    2920 (defun apply-output-translations (path)
     2980(defun* translate-pathname* (path absolute-source destination &optional root source)
     2981  (declare (ignore source))
     2982  (cond
     2983    ((functionp destination)
     2984     (funcall destination path absolute-source))
     2985    ((eq destination t)
     2986     path)
     2987    ((not (pathnamep destination))
     2988     (error "invalid destination"))
     2989    ((not (absolute-pathname-p destination))
     2990     (translate-pathname path absolute-source (merge-pathnames* destination root)))
     2991    (root
     2992     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
     2993    (t
     2994     (translate-pathname path absolute-source destination))))
     2995
     2996(defun* apply-output-translations (path)
    29212997  (etypecase path
    29222998    (logical-pathname
     
    29353011                                (t source))
    29363012       :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)))
     3013       :return (translate-pathname* p absolute-source destination root source)
    29513014       :finally (return p)))))
    29523015
     
    29613024   t))
    29623025
    2963 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
     3026(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
    29643027  (or output-file
    29653028      (apply-output-translations
     
    29683031              keys))))
    29693032
    2970 (defun tmpize-pathname (x)
     3033(defun* tmpize-pathname (x)
    29713034  (make-pathname
    29723035   :name (format nil "ASDF-TMP-~A" (pathname-name x))
    29733036   :defaults x))
    29743037
    2975 (defun delete-file-if-exists (x)
     3038(defun* delete-file-if-exists (x)
    29763039  (when (and x (probe-file x))
    29773040    (delete-file x)))
    29783041
    2979 (defun compile-file* (input-file &rest keys &key &allow-other-keys)
     3042(defun* compile-file* (input-file &rest keys &key &allow-other-keys)
    29803043  (let* ((output-file (apply 'compile-file-pathname* input-file keys))
    29813044         (tmp-file (tmpize-pathname output-file))
     
    30023065
    30033066#+abcl
    3004 (defun translate-jar-pathname (source wildcard)
     3067(defun* translate-jar-pathname (source wildcard)
    30053068  (declare (ignore wildcard))
    30063069  (let* ((p (pathname (first (pathname-device source))))
     
    30183081;;;; Compatibility mode for ASDF-Binary-Locations
    30193082
    3020 (defun enable-asdf-binary-locations-compatibility
     3083(defun* enable-asdf-binary-locations-compatibility
    30213084    (&key
    30223085     (centralize-lisp-binaries nil)
     
    30573120(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
    30583121
    3059 (defun read-null-terminated-string (s)
     3122(defun* read-null-terminated-string (s)
    30603123  (with-output-to-string (out)
    30613124    (loop :for code = (read-byte s)
     
    30633126      :do (write-char (code-char code) out))))
    30643127
    3065 (defun read-little-endian (s &optional (bytes 4))
     3128(defun* read-little-endian (s &optional (bytes 4))
    30663129  (loop
    30673130    :for i :from 0 :below bytes
    30683131    :sum (ash (read-byte s) (* 8 i))))
    30693132
    3070 (defun parse-file-location-info (s)
     3133(defun* parse-file-location-info (s)
    30713134  (let ((start (file-position s))
    30723135        (total-length (read-little-endian s))
     
    30923155          (read-null-terminated-string s))))))
    30933156
    3094 (defun parse-windows-shortcut (pathname)
     3157(defun* parse-windows-shortcut (pathname)
    30953158  (with-open-file (s pathname :element-type '(unsigned-byte 8))
    30963159    (handler-case
     
    31303193  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
    31313194    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    3132     "_sgbak" "autom4te.cache" "cover_db" "_build"))
     3195    "_sgbak" "autom4te.cache" "cover_db" "_build"
     3196    "debian")) ;; debian often build stuff under the debian directory... BAD.
    31333197
    31343198(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     
    31383202said element itself being a list of directory pathnames where to look for .asd files")
    31393203
    3140 (defun source-registry ()
     3204(defun* source-registry ()
    31413205  (car *source-registry*))
    31423206
    3143 (defun (setf source-registry) (new-value)
     3207(defun* (setf source-registry) (new-value)
    31443208  (setf *source-registry* (list new-value))
    31453209  new-value)
    31463210
    3147 (defun source-registry-initialized-p ()
     3211(defun* source-registry-initialized-p ()
    31483212  (and *source-registry* t))
    31493213
    3150 (defun clear-source-registry ()
     3214(defun* clear-source-registry ()
    31513215  "Undoes any initialization of the source registry.
    31523216You might want to call that before you dump an image that would be resumed
     
    31553219  (values))
    31563220
    3157 (defun validate-source-registry-directive (directive)
     3221(defun* validate-source-registry-directive (directive)
    31583222  (unless
    31593223      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
     
    31693233  directive)
    31703234
    3171 (defun validate-source-registry-form (form)
     3235(defun* validate-source-registry-form (form)
    31723236  (validate-configuration-form
    31733237   form :source-registry 'validate-source-registry-directive "a source registry"))
    31743238
    3175 (defun validate-source-registry-file (file)
     3239(defun* validate-source-registry-file (file)
    31763240  (validate-configuration-file
    31773241   file 'validate-source-registry-form "a source registry"))
    31783242
    3179 (defun validate-source-registry-directory (directory)
     3243(defun* validate-source-registry-directory (directory)
    31803244  (validate-configuration-directory
    31813245   directory :source-registry 'validate-source-registry-directive))
    31823246
    3183 (defun parse-source-registry-string (string)
     3247(defun* parse-source-registry-string (string)
    31843248  (cond
    31853249    ((or (null string) (equal string ""))
     
    32153279           (return `(:source-registry ,@(nreverse directives))))))))))
    32163280
    3217 (defun register-asd-directory (directory &key recurse exclude collect)
     3281(defun* register-asd-directory (directory &key recurse exclude collect)
    32183282  (if (not recurse)
    32193283      (funcall collect directory)
     
    32463310(defparameter *source-registry-directory* #p"source-registry.conf.d/")
    32473311
    3248 (defun wrapping-source-registry ()
     3312(defun* wrapping-source-registry ()
    32493313  `(:source-registry
    32503314    #+sbcl (:tree ,(getenv "SBCL_HOME"))
    32513315    :inherit-configuration
    32523316    #+cmu (:tree #p"modules:")))
    3253 (defun default-source-registry ()
     3317(defun* default-source-registry ()
    32543318  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    32553319    `(:source-registry
     
    32773341           :collect `(:tree ,(try dir "common-lisp/source/"))))
    32783342      :inherit-configuration)))
    3279 (defun user-source-registry ()
     3343(defun* user-source-registry ()
    32803344  (in-user-configuration-directory *source-registry-file*))
    3281 (defun system-source-registry ()
     3345(defun* system-source-registry ()
    32823346  (in-system-configuration-directory *source-registry-file*))
    3283 (defun user-source-registry-directory ()
     3347(defun* user-source-registry-directory ()
    32843348  (in-user-configuration-directory *source-registry-directory*))
    3285 (defun system-source-registry-directory ()
     3349(defun* system-source-registry-directory ()
    32863350  (in-system-configuration-directory *source-registry-directory*))
    3287 (defun environment-source-registry ()
     3351(defun* environment-source-registry ()
    32883352  (getenv "CL_SOURCE_REGISTRY"))
    32893353
    3290 (defgeneric process-source-registry (spec &key inherit register))
     3354(defgeneric* process-source-registry (spec &key inherit register))
    32913355(declaim (ftype (function (t &key (:register (or symbol function))) t)
    32923356                inherit-source-registry))
     
    33173381      (process-source-registry-directive directive :inherit inherit :register register))))
    33183382
    3319 (defun inherit-source-registry (inherit &key register)
     3383(defun* inherit-source-registry (inherit &key register)
    33203384  (when inherit
    33213385    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
    33223386
    3323 (defun process-source-registry-directive (directive &key inherit register)
     3387(defun* process-source-registry-directive (directive &key inherit register)
    33243388  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
    33253389    (ecase kw
     
    33473411  nil)
    33483412
    3349 (defun flatten-source-registry (&optional parameter)
     3413(defun* flatten-source-registry (&optional parameter)
    33503414  (remove-duplicates
    33513415   (while-collecting (collect)
     
    33603424;; Will read the configuration and initialize all internal variables,
    33613425;; and return the new configuration.
    3362 (defun compute-source-registry (&optional parameter)
     3426(defun* compute-source-registry (&optional parameter)
    33633427  (while-collecting (collect)
    33643428    (dolist (entry (flatten-source-registry parameter))
     
    33683432         :recurse recurse :exclude exclude :collect #'collect)))))
    33693433
    3370 (defun initialize-source-registry (&optional parameter)
     3434(defun* initialize-source-registry (&optional parameter)
    33713435  (setf (source-registry) (compute-source-registry parameter)))
    33723436
     
    33793443;; you may override the configuration explicitly by calling
    33803444;; initialize-source-registry directly with your parameter.
    3381 (defun ensure-source-registry (&optional parameter)
     3445(defun* ensure-source-registry (&optional parameter)
    33823446  (if (source-registry-initialized-p)
    33833447      (source-registry)
    33843448      (initialize-source-registry parameter)))
    33853449
    3386 (defun sysdef-source-registry-search (system)
     3450(defun* sysdef-source-registry-search (system)
    33873451  (ensure-source-registry)
    33883452  (loop :with name = (coerce-name system)
     
    33913455    :when file :return file))
    33923456
     3457(defun* clear-configuration ()
     3458  (clear-source-registry)
     3459  (clear-output-translations))
     3460
    33933461;;;; -----------------------------------------------------------------
    33943462;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
    33953463;;;;
    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*))
     3464(defun* module-provide-asdf (name)
     3465  (handler-bind
     3466      ((style-warning #'muffle-warning)
     3467       (missing-component (constantly nil))
     3468       (error (lambda (e)
     3469                (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
     3470                        name e))))
     3471    (let* ((*verbose-out* (make-broadcast-stream))
     3472           (system (find-system (string-downcase name) nil)))
     3473      (when system
     3474        (load-system system)
     3475        t))))
     3476
     3477#+(or abcl clisp clozure cmu ecl sbcl)
     3478(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
     3479  (when x
     3480    (eval `(pushnew 'module-provide-asdf
     3481            #+abcl sys::*module-provider-functions*
     3482            #+clisp ,x
     3483            #+clozure ccl:*module-provider-functions*
     3484            #+cmu ext:*module-provider-functions*
     3485            #+ecl si:*module-provider-functions*
     3486            #+sbcl sb-ext:*module-provider-functions*))))
     3487
    34163488
    34173489;;;; -------------------------------------------------------------------------
Note: See TracChangeset for help on using the changeset viewer.