Ignore:
Timestamp:
06/25/10 10:46:06 (12 years ago)
Author:
Mark Evenson
Message:

Update to ASDF-2.003 with local patches.

Local patches differentiate output location by FASL and Java version.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r12666 r12765  
    4848#+xcvb (module ())
    4949
    50 (cl:in-package :cl-user)
    51 
    52 (declaim (optimize (speed 2) (debug 2) (safety 3))
    53          #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
    54 
    55 #+ecl (require :cmp)
    56 
    57 ;;;; Create packages in a way that is compatible with hot-upgrade.
    58 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    59 ;;;; See more at the end of the file.
    60 
    61 #+gcl
    62 (eval-when (:compile-toplevel :load-toplevel)
    63   (defpackage :asdf-utilities (:use :cl))
    64   (defpackage :asdf (:use :cl :asdf-utilities)))
    65 
    66 (eval-when (:load-toplevel :compile-toplevel :execute)
     50(cl:in-package :cl)
     51(defpackage :asdf-bootstrap (:use :cl))
     52(in-package :asdf-bootstrap)
     53
     54;; Implementation-dependent tweaks
     55(eval-when (:compile-toplevel :load-toplevel :execute)
     56  ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
    6757  #+allegro
    6858  (setf excl::*autoload-package-name-alist*
    6959        (remove "asdf" excl::*autoload-package-name-alist*
    7060                :test 'equalp :key 'car))
    71   (let* ((asdf-version
    72           ;; the 1+ helps the version bumping script discriminate
    73           (subseq "VERSION:1.719" (1+ (length "VERSION"))))
     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))))
     66
     67;;;; Create packages in a way that is compatible with hot-upgrade.
     68;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     69;;;; See more at the end of the file.
     70
     71(eval-when (:load-toplevel :compile-toplevel :execute)
     72  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
     73          (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105.
    7474         (existing-asdf (find-package :asdf))
    7575         (vername '#:*asdf-version*)
    … …  
    8181      #-gcl
    8282      (when existing-asdf
    83         (format *error-output*
     83        (format *trace-output*
    8484                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    8585                existing-version asdf-version))
    … …  
    156156            ((pkgdcl (name &key nicknames use export
    157157                           redefined-functions unintern fmakunbound shadow)
    158                `(ensure-package
    159                  ',name :nicknames ',nicknames :use ',use :export ',export
    160                  :shadow ',shadow
    161                  :unintern ',(append #-(or gcl ecl) redefined-functions
    162                                      unintern)
    163                  :fmakunbound ',(append #+(or gcl ecl) redefined-functions
    164                                         fmakunbound))))
     158                 `(ensure-package
     159                   ',name :nicknames ',nicknames :use ',use :export ',export
     160                   :shadow ',shadow
     161                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
     162                   :fmakunbound ',(append fmakunbound))))
    165163          (pkgdcl
    166164           :asdf-utilities
    … …  
    291289            #:ensure-output-translations
    292290            #:apply-output-translations
     291            #:compile-file*
    293292            #:compile-file-pathname*
    294293            #:enable-asdf-binary-locations-compatibility
    … …  
    328327           ((m module) added deleted plist &key)
    329328         (declare (ignorable deleted plist))
     329         (format *trace-output* "Updating ~A~%" m)
    330330         (when (member 'components-by-name added)
    331331           (compute-module-components-by-name m))))))
    … …  
    337337  "Exported interface to the version of ASDF currently installed. A string.
    338338You can compare this string with e.g.:
    339 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
     339(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
    340340  *asdf-version*)
    341341
    … …  
    345345Defaults to `t`.")
    346346
    347 (defvar *compile-file-warnings-behaviour* :warn)
    348 
    349 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
     347(defvar *compile-file-warnings-behaviour* :warn
     348  "How should ASDF react if it encounters a warning when compiling a
     349file?  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
     353ANSI spec of COMPILE-FILE\) when compiling a file?  Valid values are
     354:error, :warn, and :ignore.  Note that ASDF ALWAYS raises an error
     355if it fails to create an output file when compiling.")
    350356
    351357(defvar *verbose-out* nil)
    … …  
    366372;;;; -------------------------------------------------------------------------
    367373;;;; ASDF Interface, in terms of generic functions.
    368 
    369 (defgeneric perform-with-restarts (operation component))
    370 (defgeneric perform (operation component))
    371 (defgeneric operation-done-p (operation component))
    372 (defgeneric explain (operation component))
    373 (defgeneric output-files (operation component))
    374 (defgeneric input-files (operation component))
     374(defmacro defgeneric* (name formals &rest options)
     375  `(progn
     376     #+(or gcl ecl) (fmakunbound ',name)
     377     (defgeneric ,name ,formals ,@options)))
     378
     379(defgeneric* perform-with-restarts (operation component))
     380(defgeneric* perform (operation component))
     381(defgeneric* operation-done-p (operation component))
     382(defgeneric* explain (operation component))
     383(defgeneric* output-files (operation component))
     384(defgeneric* input-files (operation component))
    375385(defgeneric component-operation-time (operation component))
    376386
    377 (defgeneric system-source-file (system)
     387(defgeneric* system-source-file (system)
    378388  (:documentation "Return the source file in which system is defined."))
    379389
    … …  
    397407(defgeneric version-satisfies (component version))
    398408
    399 (defgeneric find-component (base path)
     409(defgeneric* find-component (base path)
    400410  (:documentation "Finds the component with PATH starting from BASE module;
    401411if BASE is nil, then the component is assumed to be a system."))
    … …  
    456466(defgeneric traverse (operation component)
    457467  (:documentation
    458 "Generate and return a plan for performing `operation` on `component`.
    459 
    460 The plan returned is a list of dotted-pairs. Each pair is the `cons`
    461 of ASDF operation object and a `component` object. The pairs will be
    462 processed in order by `operate`."))
     468"Generate and return a plan for performing OPERATION on COMPONENT.
     469
     470The plan returned is a list of dotted-pairs. Each pair is the CONS
     471of ASDF operation object and a COMPONENT object. The pairs will be
     472processed in order by OPERATE."))
    463473
    464474
    … …  
    467477
    468478(defmacro while-collecting ((&rest collectors) &body body)
     479  "COLLECTORS should be a list of names for collections.  A collector
     480defines a function that, when applied to an argument inside BODY, will
     481add its argument to the corresponding collection.  Returns multiple values,
     482a list for each collection, in order.
     483   E.g.,
     484\(while-collecting \(foo bar\)
     485           \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
     486             \(foo \(first x\)\)
     487             \(bar \(second x\)\)\)\)
     488Returns two values: \(A B C\) and \(1 2 3\)."
    469489  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
    470490        (initial-values (mapcar (constantly nil) collectors)))
    … …  
    480500  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    481501and NIL NAME, TYPE and VERSION components"
    482   (make-pathname :name nil :type nil :version nil :defaults pathname))
    483 
    484 (defun current-directory ()
    485   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     502  (when pathname
     503    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    486504
    487505(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    … …  
    494512         (defaults (pathname defaults))
    495513         (directory (pathname-directory specified))
    496          (directory (if (stringp directory) `(:absolute ,directory) directory))
     514         #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
    497515         (name (or (pathname-name specified) (pathname-name defaults)))
    498516         (type (or (pathname-type specified) (pathname-type defaults)))
    … …  
    517535             (values (pathname-host defaults)
    518536                     (pathname-device defaults)
    519                      (if (null (pathname-directory defaults))
    520                          directory
    521                          (append (pathname-directory defaults) (cdr directory)))
     537                     (if (pathname-directory defaults)
     538                         (append (pathname-directory defaults) (cdr directory))
     539                         directory)
    522540                     (unspecific-handler defaults)))
    523541            #+gcl
    … …  
    539557  or "or a flag")
    540558
     559(defun first-char (s)
     560  (and (stringp s) (plusp (length s)) (char s 0)))
     561
     562(defun last-char (s)
     563  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
     564
    541565(defun asdf-message (format-string &rest format-args)
    542566  (declare (dynamic-extent format-args))
    … …  
    544568
    545569(defun split-string (string &key max (separator '(#\Space #\Tab)))
    546   "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
    547 return a list.
     570  "Split STRING into a list of components separated by
     571any of the characters in the sequence SEPARATOR.
    548572If MAX is specified, then no more than max(1,MAX) components will be returned,
    549573starting the separation from the end, e.g. when called with arguments
    … …  
    596620    (multiple-value-bind (relative components)
    597621        (if (equal (first components) "")
    598             (if (and (plusp (length s)) (eql (char s 0) #\/))
     622            (if (equal (first-char s) #\/)
    599623                (values :absolute (cdr components))
    600624                (values :relative nil))
    601625          (values :relative components))
     626      (setf components (remove "" components :test #'equal))
    602627      (cond
    603628        ((equal last-comp "")
    604          (values relative (butlast components) nil))
     629         (values relative components nil)) ; "" already removed
    605630        (force-directory
    606631         (values relative components nil))
    … …  
    618643    :unless (eq k key)
    619644    :append (list k v)))
    620 
    621 (defun resolve-symlinks (path)
    622   #-allegro (truenamize path)
    623   #+allegro (excl:pathname-resolve-symbolic-links path))
    624645
    625646(defun getenv (x)
    … …  
    629650  (sb-ext:posix-getenv x)
    630651  #+clozure
    631   (ccl::getenv x)
     652  (ccl:getenv x)
    632653  #+clisp
    633654  (ext:getenv x)
    … …  
    644665
    645666(defun directory-pathname-p (pathname)
    646   "Does `pathname` represent a directory?
     667  "Does PATHNAME represent a directory?
    647668
    648669A directory-pathname is a pathname _without_ a filename. The three
    649 ways that the filename components can be missing are for it to be `nil`,
    650 `:unspecific` or the empty string.
    651 
    652 Note that this does _not_ check to see that `pathname` points to an
     670ways that the filename components can be missing are for it to be NIL,
     671:UNSPECIFIC or the empty string.
     672
     673Note that this does _not_ check to see that PATHNAME points to an
    653674actually-existing directory."
    654675  (flet ((check-one (x)
    … …  
    734755      (when (typep p 'logical-pathname) (return p))
    735756      (ignore-errors (return (truename p)))
    736       (when (stringp directory)
    737          (return p))
    738       (when (not (eq :absolute (car directory)))
    739         (return p))
     757      #-sbcl (when (stringp directory) (return p))
     758      (when (not (eq :absolute (car directory))) (return p))
    740759      (let ((sofar (ignore-errors (truename (pathname-root p)))))
    741760        (unless sofar (return p))
    … …  
    761780            (return (solution nil))))))))
    762781
     782(defun resolve-symlinks (path)
     783  #-allegro (truenamize path)
     784  #+allegro (excl:pathname-resolve-symbolic-links path))
     785
     786(defun default-directory ()
     787  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     788
    763789(defun lispize-pathname (input-file)
    764790  (make-pathname :type "lisp" :defaults input-file))
     791
     792(defparameter *wild-path*
     793  (make-pathname :directory '(:relative :wild-inferiors)
     794                 :name :wild :type :wild :version :wild))
     795
     796(defun wilden (path)
     797  (merge-pathnames* *wild-path* path))
     798
     799(defun directorize-pathname-host-device (pathname)
     800  (let* ((root (pathname-root pathname))
     801         (wild-root (wilden root))
     802         (absolute-pathname (merge-pathnames* pathname root))
     803         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
     804         (separator (last-char (namestring foo)))
     805         (root-namestring (namestring root))
     806         (root-string
     807          (substitute-if #\/
     808                         (lambda (x) (or (eql x #\:)
     809                                         (eql x separator)))
     810                         root-namestring)))
     811    (multiple-value-bind (relative path filename)
     812        (component-name-to-pathname-components root-string t)
     813      (declare (ignore relative filename))
     814      (let ((new-base
     815             (make-pathname :defaults root
     816                            :directory `(:absolute ,@path))))
     817        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    765818
    766819;;;; -------------------------------------------------------------------------
    … …  
    775828  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    776829  #+cmu (:report print-object))
     830
     831(declaim (ftype (function (t) t)
     832                format-arguments format-control
     833                error-name error-pathname error-condition
     834                duplicate-names-name
     835                error-component error-operation
     836                module-components module-components-by-name)
     837         (ftype (function (t t) t) (setf module-components-by-name)))
     838
    777839
    778840(define-condition formatted-system-definition-error (system-definition-error)
    … …  
    895957
    896958(defun compute-module-components-by-name (module)
    897   (let ((hash (module-components-by-name module)))
    898     (clrhash hash)
     959  (let ((hash (make-hash-table :test 'equal)))
     960    (setf (module-components-by-name module) hash)
    899961    (loop :for c :in (module-components module)
    900962      :for name = (component-name c)
    … …  
    912974    :accessor module-components)
    913975   (components-by-name
    914     :initform (make-hash-table :test 'equal)
    915976    :accessor module-components-by-name)
    916977   ;; What to do if we can't satisfy a dependency of one of this module's
    … …  
    9401001             (merge-pathnames*
    9411002             (component-relative-pathname component)
    942              (component-parent-pathname component))))
     1003             (pathname-directory-pathname (component-parent-pathname component)))))
    9431004        (unless (or (null pathname) (absolute-pathname-p pathname))
    9441005          (error "Invalid relative pathname ~S for component ~S" pathname component))
    … …  
    10141075
    10151076(defun map-systems (fn)
    1016   "Apply `fn` to each defined system.
    1017 
    1018 `fn` should be a function of one argument. It will be
     1077  "Apply FN to each defined system.
     1078
     1079FN should be a function of one argument. It will be
    10191080called with an object of type asdf:system."
    10201081  (maphash (lambda (_ datum)
    … …  
    10291090
    10301091(defparameter *system-definition-search-functions*
    1031   '(sysdef-central-registry-search sysdef-source-registry-search))
     1092  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    10321093
    10331094(defun system-definition-pathname (system)
    … …  
    10541115Going forward, we recommend new users should be using the source-registry.
    10551116")
     1117
     1118(defun probe-asd (name defaults)
     1119  (block nil
     1120    (when (directory-pathname-p defaults)
     1121      (let ((file
     1122             (make-pathname
     1123              :defaults defaults :version :newest :case :local
     1124              :name name
     1125              :type "asd")))
     1126        (when (probe-file file)
     1127          (return file)))
     1128      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     1129      (let ((shortcut
     1130             (make-pathname
     1131              :defaults defaults :version :newest :case :local
     1132              :name (concatenate 'string name ".asd")
     1133              :type "lnk")))
     1134        (when (probe-file shortcut)
     1135          (let ((target (parse-windows-shortcut shortcut)))
     1136            (when target
     1137              (return (pathname target)))))))))
    10561138
    10571139(defun sysdef-central-registry-search (system)
    … …  
    10731155                                   (message
    10741156                                    (format nil
    1075                                             "~@<While searching for system `~a`: `~a` evaluated ~
    1076 to `~a` which is not a directory.~@:>"
     1157                                            "~@<While searching for system ~S: ~S evaluated ~
     1158to ~S which is not a directory.~@:>"
    10771159                                            system dir defaults)))
    10781160                              (error message))
    … …  
    11231205
    11241206(defun find-system (name &optional (error-p t))
    1125   (let* ((name (coerce-name name))
    1126          (in-memory (system-registered-p name))
    1127          (on-disk (system-definition-pathname name)))
    1128     (when (and on-disk
    1129                (or (not in-memory)
    1130                    (< (car in-memory) (safe-file-write-date on-disk))))
    1131       (let ((package (make-temporary-package)))
    1132         (unwind-protect
    1133              (handler-bind
    1134                  ((error (lambda (condition)
    1135                            (error 'load-system-definition-error
    1136                                   :name name :pathname on-disk
    1137                                   :condition condition))))
    1138                (let ((*package* package))
    1139                  (asdf-message
    1140                   "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    1141                   on-disk *package*)
    1142                  (load on-disk)))
    1143           (delete-package package))))
    1144     (let ((in-memory (system-registered-p name)))
    1145       (if in-memory
    1146           (progn (when on-disk (setf (car in-memory)
    1147                                      (safe-file-write-date on-disk)))
    1148                  (cdr in-memory))
    1149           (when error-p (error 'missing-component :requires name))))))
     1207  (catch 'find-system
     1208    (let* ((name (coerce-name name))
     1209           (in-memory (system-registered-p name))
     1210           (on-disk (system-definition-pathname name)))
     1211      (when (and on-disk
     1212                 (or (not in-memory)
     1213                     (< (car in-memory) (safe-file-write-date on-disk))))
     1214        (let ((package (make-temporary-package)))
     1215          (unwind-protect
     1216               (handler-bind
     1217                   ((error (lambda (condition)
     1218                             (error 'load-system-definition-error
     1219                                    :name name :pathname on-disk
     1220                                    :condition condition))))
     1221                 (let ((*package* package))
     1222                   (asdf-message
     1223                    "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     1224                    on-disk *package*)
     1225                   (load on-disk)))
     1226            (delete-package package))))
     1227      (let ((in-memory (system-registered-p name)))
     1228        (if in-memory
     1229            (progn (when on-disk (setf (car in-memory)
     1230                                       (safe-file-write-date on-disk)))
     1231                   (cdr in-memory))
     1232            (when error-p (error 'missing-component :requires name)))))))
    11501233
    11511234(defun register-system (name system)
    … …  
    11531236  (setf (gethash (coerce-name name) *defined-systems*)
    11541237        (cons (get-universal-time) system)))
     1238
     1239(defun sysdef-find-asdf (system)
     1240  (let ((name (coerce-name system)))
     1241    (when (equal name "asdf")
     1242      (let* ((registered (cdr (gethash name *defined-systems*)))
     1243             (asdf (or registered
     1244                       (make-instance
     1245                        'system :name "asdf"
     1246                        :source-file (or *compile-file-truename* *load-truename*)))))
     1247        (unless registered
     1248          (register-system "asdf" asdf))
     1249        (throw 'find-system asdf)))))
    11551250
    11561251
    … …  
    11721267
    11731268(defmethod find-component ((module module) (name string))
    1174   (when (slot-boundp module 'components-by-name)
    1175     (values (gethash name (module-components-by-name module)))))
     1269  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
     1270    (compute-module-components-by-name module))
     1271  (values (gethash name (module-components-by-name module))))
    11761272
    11771273(defmethod find-component ((component component) (name symbol))
    … …  
    16031699      flag))
    16041700
    1605 (defmethod traverse ((operation operation) (c component))
    1606   ;; cerror'ing a feature that seems to have NEVER EVER worked
    1607   ;; ever since danb created it in his 2003-03-16 commit e0d02781.
    1608   ;; It was both fixed and disabled in the 1.700 rewrite.
    1609   (when (consp (operation-forced operation))
    1610     (cerror "Continue nonetheless."
    1611             "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
    1612     (setf (operation-forced operation)
    1613           (mapcar #'coerce-name (operation-forced operation))))
    1614   (flatten-tree
    1615    (while-collecting (collect)
    1616      (do-traverse operation c #'collect))))
    1617 
    16181701(defun flatten-tree (l)
    16191702  ;; You collected things into a list.
    … …  
    16321715      (r* l))))
    16331716
     1717(defmethod traverse ((operation operation) (c component))
     1718  ;; cerror'ing a feature that seems to have NEVER EVER worked
     1719  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
     1720  ;; It was both fixed and disabled in the 1.700 rewrite.
     1721  (when (consp (operation-forced operation))
     1722    (cerror "Continue nonetheless."
     1723            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
     1724    (setf (operation-forced operation)
     1725          (mapcar #'coerce-name (operation-forced operation))))
     1726  (flatten-tree
     1727   (while-collecting (collect)
     1728     (do-traverse operation c #'collect))))
     1729
    16341730(defmethod perform ((operation operation) (c source-file))
    16351731  (sysdef-error
    … …  
    16731769        (get-universal-time)))
    16741770
     1771(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
     1772                          (values t t t))
     1773                compile-file*))
     1774
    16751775;;; perform is required to check output-files to find out where to put
    16761776;;; its answers, in case it has been overridden for site policy
    … …  
    16781778  #-:broken-fasl-loader
    16791779  (let ((source-file (component-pathname c))
    1680         (output-file (car (output-files operation c))))
     1780        (output-file (car (output-files operation c)))
     1781        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
     1782        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    16811783    (multiple-value-bind (output warnings-p failure-p)
    1682         (apply #'compile-file source-file :output-file output-file
     1784        (apply #'compile-file* source-file :output-file output-file
    16831785               (compile-op-flags operation))
    16841786      (when warnings-p
    … …  
    18561958;;;; Invoking Operations
    18571959
    1858 (defgeneric operate (operation-class system &key &allow-other-keys))
     1960(defgeneric* operate (operation-class system &key &allow-other-keys))
    18591961
    18601962(defmethod operate (operation-class system &rest args
    … …  
    19042006  "Operate does three things:
    19052007
    1906 1. It creates an instance of `operation-class` using any keyword parameters
     20081. It creates an instance of OPERATION-CLASS using any keyword parameters
    19072009as initargs.
    1908 2. It finds the  asdf-system specified by `system` (possibly loading
     20102. It finds the  asdf-system specified by SYSTEM (possibly loading
    19092011it from disk).
    1910 3. It then calls `traverse` with the operation and system as arguments
    1911 
    1912 The traverse operation is wrapped in `with-compilation-unit` and error
    1913 handling code. If a `version` argument is supplied, then operate also
    1914 ensures that the system found satisfies it using the `version-satisfies`
     20123. It then calls TRAVERSE with the operation and system as arguments
     2013
     2014The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
     2015handling code. If a VERSION argument is supplied, then operate also
     2016ensures that the system found satisfies it using the VERSION-SATISFIES
    19152017method.
    19162018
    … …  
    19502052;;;; Defsystem
    19512053
     2054(defun load-pathname ()
     2055  (let ((pn (or *load-pathname* *compile-file-pathname*)))
     2056    (if *resolve-symlinks*
     2057        (and pn (resolve-symlinks pn))
     2058        pn)))
     2059
    19522060(defun determine-system-pathname (pathname pathname-supplied-p)
    1953   ;; called from the defsystem macro.
    1954   ;; the pathname of a system is either
     2061  ;; The defsystem macro calls us to determine
     2062  ;; the pathname of a system as follows:
    19552063  ;; 1. the one supplied,
    1956   ;; 2. derived from the *load-truename* (see below), or
    1957   ;; 3. taken from *default-pathname-defaults*
    1958   ;;
    1959   ;; if using *load-truename*, then we also deal with whether or not
    1960   ;; to resolve symbolic links. If not resolving symlinks, then we use
    1961   ;; *load-pathname* instead of *load-truename* since in some
    1962   ;; implementations, the latter has *already resolved it.
    1963   (let ((file-pathname
    1964          (when (or *load-pathname* *compile-file-pathname*)
    1965            (pathname-directory-pathname
    1966             (if *resolve-symlinks*
    1967                 (resolve-symlinks (or *load-truename* *compile-file-truename*))
    1968                 *load-pathname*)))))
    1969     (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
     2064  ;; 2. derived from *load-pathname* via load-pathname
     2065  ;; 3. taken from the *default-pathname-defaults* via default-directory
     2066  (let* ((file-pathname (load-pathname))
     2067         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
     2068    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
    19702069        file-pathname
    1971         (current-directory))))
     2070        (default-directory))))
    19722071
    19732072(defmacro defsystem (name &body options)
    … …  
    19902089                  (register-system (quote ,name)
    19912090                                   (make-instance ',class :name ',name))))
    1992            (%set-system-source-file *load-truename*
     2091           (%set-system-source-file (load-pathname)
    19932092                                    (cdr (system-registered-p ',name))))
    19942093         (parse-component-form
    … …  
    19992098               ',component-options))))))
    20002099
    2001 
    20022100(defun class-for-type (parent type)
    2003   (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
    2004                               (find-symbol (symbol-name type)
    2005                                            (load-time-value
    2006                                             (package-name :asdf)))))
    2007          (class (dolist (symbol (if (keywordp type)
    2008                                     extra-symbols
    2009                                     (cons type extra-symbols)))
    2010                   (when (and symbol
    2011                              (find-class symbol nil)
    2012                              (subtypep symbol 'component))
    2013                     (return (find-class symbol))))))
    2014     (or class
    2015         (and (eq type :file)
    2016              (or (module-default-component-class parent)
    2017                  (find-class 'cl-source-file)))
    2018         (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
     2101  (or (loop :for symbol :in (list
     2102                             (unless (keywordp type) type)
     2103                             (find-symbol (symbol-name type) *package*)
     2104                             (find-symbol (symbol-name type) :asdf))
     2105        :for class = (and symbol (find-class symbol nil))
     2106        :when (and class (subtypep class 'component))
     2107        :return class)
     2108      (and (eq type :file)
     2109           (or (module-default-component-class parent)
     2110               (find-class *default-component-class*)))
     2111      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
    20192112
    20202113(defun maybe-add-tree (tree op1 op2 c)
    … …  
    21792272
    21802273(defun run-shell-command (control-string &rest args)
    2181   "Interpolate `args` into `control-string` as if by `format`, and
     2274  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    21822275synchronously execute the result using a Bourne-compatible shell, with
    2183 output to `*verbose-out*`.  Returns the shell's exit code."
     2276output to *VERBOSE-OUT*.  Returns the shell's exit code."
    21842277  (let ((command (apply #'format nil control-string args)))
    21852278    (asdf-message "; $ ~A~%" command)
    … …  
    23342427    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
    23352428    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2336     #+(or mcl sbcl scl) s
     2429    #+(or cormanlisp mcl sbcl scl) s
    23372430    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
    23382431          ecl gcl lispworks mcl sbcl scl) s))
    … …  
    24542547    (funcall validator (car forms))))
    24552548
     2549(defun hidden-file-p (pathname)
     2550  (equal (first-char (pathname-name pathname)) #\.))
     2551
    24562552(defun validate-configuration-directory (directory tag validator)
    24572553  (let ((files (sort (ignore-errors
    2458                        (directory (make-pathname :name :wild :type :wild :defaults directory)
    2459                                   #+sbcl :resolve-symlinks #+sbcl nil))
     2554                       (remove-if
     2555                        'hidden-file-p
     2556                        (directory (make-pathname :name :wild :type "conf" :defaults directory)
     2557                                   #+sbcl :resolve-symlinks #+sbcl nil)))
    24602558                     #'string< :key #'namestring)))
    24612559    `(,tag
    … …  
    25142612  (values))
    25152613
    2516 (defparameter *wild-path*
    2517   (make-pathname :directory '(:relative :wild-inferiors)
    2518                  :name :wild :type :wild :version :wild))
    2519 
    25202614(defparameter *wild-asd*
    25212615  (make-pathname :directory '(:relative :wild-inferiors)
    25222616                 :name :wild :type "asd" :version :newest))
    25232617
    2524 (defun wilden (path)
    2525   (merge-pathnames* *wild-path* path))
     2618
     2619(declaim (ftype (function (t &optional boolean) (or null pathname))
     2620                resolve-location))
     2621
     2622(defun resolve-relative-location-component (super x &optional wildenp)
     2623  (let* ((r (etypecase x
     2624              (pathname x)
     2625              (string x)
     2626              (cons
     2627               (let ((car (resolve-relative-location-component super (car x) nil)))
     2628                 (if (null (cdr x))
     2629                     car
     2630                     (let ((cdr (resolve-relative-location-component
     2631                                 (merge-pathnames* car super) (cdr x) wildenp)))
     2632                       (merge-pathnames* cdr car)))))
     2633              ((eql :default-directory)
     2634               (relativize-pathname-directory (default-directory)))
     2635              ((eql :implementation) (implementation-identifier))
     2636              ((eql :implementation-type) (string-downcase (implementation-type)))
     2637              #-(and (or win32 windows mswindows mingw32) (not cygwin))
     2638              ((eql :uid) (princ-to-string (get-uid)))))
     2639         (d (if (pathnamep x) r (ensure-directory-pathname r)))
     2640         (s (if (and wildenp (not (pathnamep x)))
     2641                (wilden d)
     2642                d)))
     2643    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
     2644      (error "pathname ~S is not relative to ~S" s super))
     2645    (merge-pathnames* s super)))
    25262646
    25272647(defun resolve-absolute-location-component (x wildenp)
    … …  
    25452665            ((eql :user-cache) (resolve-location *user-cache* nil))
    25462666            ((eql :system-cache) (resolve-location *system-cache* nil))
    2547             ((eql :current-directory) (current-directory))))
     2667            ((eql :default-directory) (default-directory))))
    25482668         (s (if (and wildenp (not (pathnamep x)))
    25492669                (wilden r)
    … …  
    25522672      (error "Not an absolute pathname ~S" s))
    25532673    s))
    2554 
    2555 (defun resolve-relative-location-component (super x &optional wildenp)
    2556   (let* ((r (etypecase x
    2557               (pathname x)
    2558               (string x)
    2559               (cons
    2560                (let ((car (resolve-relative-location-component super (car x) nil)))
    2561                  (if (null (cdr x))
    2562                      car
    2563                      (let ((cdr (resolve-relative-location-component
    2564                                  (merge-pathnames* car super) (cdr x) wildenp)))
    2565                        (merge-pathnames* cdr car)))))
    2566               ((eql :current-directory)
    2567                (relativize-pathname-directory (current-directory)))
    2568               ((eql :implementation) (implementation-identifier))
    2569               ((eql :implementation-type) (string-downcase (implementation-type)))
    2570               ((eql :uid) (princ-to-string (get-uid)))))
    2571          (d (if (pathnamep x) r (ensure-directory-pathname r)))
    2572          (s (if (and wildenp (not (pathnamep x)))
    2573                 (wilden d)
    2574                 d)))
    2575     (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    2576       (error "pathname ~S is not relative to ~S" s super))
    2577     (merge-pathnames* s super)))
    25782674
    25792675(defun resolve-location (x &optional wildenp)
    … …  
    26822778    ;; so we must disable translations for implementation paths.
    26832779    #+sbcl (,(getenv "SBCL_HOME") ())
    2684     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
    2685     #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
     2780    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
     2781    #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
    26862782    ;; All-import, here is where we want user stuff to be:
    26872783    :inherit-configuration
    … …  
    27072803
    27082804(defgeneric process-output-translations (spec &key inherit collect))
     2805(declaim (ftype (function (t &key (:collect (or symbol function))) t)
     2806                inherit-output-translations))
     2807(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
     2808                process-output-translations-directive))
     2809
    27092810(defmethod process-output-translations ((x symbol) &key
    27102811                                        (inherit *default-output-translations*)
    … …  
    28342935       :finally (return p)))))
    28352936
    2836 (defun last-char (s)
    2837   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    2838 
    2839 (defun directorize-pathname-host-device (pathname)
    2840   (let* ((root (pathname-root pathname))
    2841          (wild-root (wilden root))
    2842          (absolute-pathname (merge-pathnames* pathname root))
    2843          (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
    2844          (separator (last-char (namestring foo)))
    2845          (root-namestring (namestring root))
    2846          (root-string
    2847           (substitute-if #\/
    2848                          (lambda (x) (or (eql x #\:)
    2849                                          (eql x separator)))
    2850                          root-namestring)))
    2851     (multiple-value-bind (relative path filename)
    2852         (component-name-to-pathname-components root-string t)
    2853       (declare (ignore relative filename))
    2854       (let ((new-base
    2855              (make-pathname :defaults root
    2856                             :directory `(:absolute ,@path))))
    2857         (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    2858 
    28592937(defmethod output-files :around (operation component)
    28602938  "Translate output files, unless asked not to"
    … …  
    28672945   t))
    28682946
    2869 (defun compile-file-pathname* (input-file &rest keys)
    2870   (apply-output-translations
    2871    (apply #'compile-file-pathname
    2872           (truenamize (lispize-pathname input-file))
    2873           keys)))
     2947(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
     2948  (or output-file
     2949      (apply-output-translations
     2950       (apply 'compile-file-pathname
     2951              (truenamize (lispize-pathname input-file))
     2952              keys))))
     2953
     2954(defun tmpize-pathname (x)
     2955  (make-pathname
     2956   :name (format nil "ASDF-TMP-~A" (pathname-name x))
     2957   :defaults x))
     2958
     2959(defun delete-file-if-exists (x)
     2960  (when (probe-file x)
     2961    (delete-file x)))
     2962
     2963(defun compile-file* (input-file &rest keys &key &allow-other-keys)
     2964  (let* ((output-file (apply 'compile-file-pathname* input-file keys))
     2965         (tmp-file (tmpize-pathname output-file))
     2966         (status :error))
     2967    (multiple-value-bind (output-truename warnings-p failure-p)
     2968        (apply 'compile-file input-file :output-file tmp-file keys)
     2969      (cond
     2970        (failure-p
     2971         (setf status *compile-file-failure-behaviour*))
     2972        (warnings-p
     2973         (setf status *compile-file-warnings-behaviour*))
     2974        (t
     2975         (setf status :success)))
     2976      (ecase status
     2977        ((:success :warn :ignore)
     2978         (delete-file-if-exists output-file)
     2979         (when output-truename
     2980           (rename-file output-truename output-file)
     2981           (setf output-truename output-file)))
     2982        (:error
     2983         (delete-file-if-exists output-truename)
     2984         (setf output-truename nil)))
     2985      (values output-truename warnings-p failure-p))))
    28742986
    28752987#+abcl
    … …  
    29993111
    30003112;; Using ack 1.2 exclusions
    3001 (defvar *default-exclusions*
     3113(defvar *default-source-registry-exclusions*
    30023114  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
    30033115    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    30043116    "_sgbak" "autom4te.cache" "cover_db" "_build"))
     3117
     3118(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    30053119
    30063120(defvar *source-registry* ()
    … …  
    30243138  (setf *source-registry* '())
    30253139  (values))
    3026 
    3027 (defun probe-asd (name defaults)
    3028   (block nil
    3029     (when (directory-pathname-p defaults)
    3030       (let ((file
    3031              (make-pathname
    3032               :defaults defaults :version :newest :case :local
    3033               :name name
    3034               :type "asd")))
    3035         (when (probe-file file)
    3036           (return file)))
    3037       #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
    3038       (let ((shortcut
    3039              (make-pathname
    3040               :defaults defaults :version :newest :case :local
    3041               :name (concatenate 'string name ".asd")
    3042               :type "lnk")))
    3043         (when (probe-file shortcut)
    3044           (let ((target (parse-windows-shortcut shortcut)))
    3045             (when target
    3046               (return (pathname target)))))))))
    3047 
    3048 (defun sysdef-source-registry-search (system)
    3049   (ensure-source-registry)
    3050   (loop :with name = (coerce-name system)
    3051     :for defaults :in (source-registry)
    3052     :for file = (probe-asd name defaults)
    3053     :when file :return file))
    30543140
    30553141(defun validate-source-registry-directive (directive)
    … …  
    30613147               (and (length=n-p rest 1)
    30623148                    (typep (car rest) '(or pathname string null))))
    3063               ((:exclude)
     3149              ((:exclude :also-exclude)
    30643150               (every #'stringp rest))
    30653151              (null rest))))
    … …  
    31473233  `(:source-registry
    31483234    #+sbcl (:tree ,(getenv "SBCL_HOME"))
    3149    :inherit-configuration))
     3235    :inherit-configuration
     3236    #+cmu (:tree #p"modules:")))
    31503237(defun default-source-registry ()
    31513238  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    … …  
    31863273
    31873274(defgeneric process-source-registry (spec &key inherit register))
     3275(declaim (ftype (function (t &key (:register (or symbol function))) t)
     3276                inherit-source-registry))
     3277(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
     3278                process-source-registry-directive))
     3279
    31883280(defmethod process-source-registry ((x symbol) &key inherit register)
    31893281  (process-source-registry (funcall x) :inherit inherit :register register))
    … …  
    32053297  (inherit-source-registry inherit :register register))
    32063298(defmethod process-source-registry ((form cons) &key inherit register)
    3207   (let ((*default-exclusions* *default-exclusions*))
     3299  (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
    32083300    (dolist (directive (cdr (validate-source-registry-form form)))
    32093301      (process-source-registry-directive directive :inherit inherit :register register))))
    … …  
    32263318       (destructuring-bind (pathname) rest
    32273319         (when pathname
    3228            (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
     3320           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
    32293321      ((:exclude)
    3230        (setf *default-exclusions* rest))
     3322       (setf *source-registry-exclusions* rest))
     3323      ((:also-exclude)
     3324       (appendf *source-registry-exclusions* rest))
    32313325      ((:default-registry)
    32323326       (inherit-source-registry '(default-source-registry) :register register))
    … …  
    32343328       (inherit-source-registry inherit :register register))
    32353329      ((:ignore-inherited-configuration)
    3236        nil))))
     3330       nil)))
     3331  nil)
    32373332
    32383333(defun flatten-source-registry (&optional parameter)
    … …  
    32693364      (initialize-source-registry)))
    32703365
     3366(defun sysdef-source-registry-search (system)
     3367  (ensure-source-registry)
     3368  (loop :with name = (coerce-name system)
     3369    :for defaults :in (source-registry)
     3370    :for file = (probe-asd name defaults)
     3371    :when file :return file))
     3372
    32713373;;;; -----------------------------------------------------------------
    32723374;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
    … …  
    32793381         (missing-component (constantly nil))
    32803382         (error (lambda (e)
    3281                   (format *error-output* "ASDF could not load ~A because ~A.~%"
     3383                  (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
    32823384                          name e))))
    32833385      (let* ((*verbose-out* (make-broadcast-stream))
    3284              (system (find-system name nil)))
     3386             (system (find-system (string-downcase name) nil)))
    32853387        (when system
    3286           (load-system name)
     3388          (load-system system)
    32873389          t))))
    32883390  (pushnew 'module-provide-asdf
    32893391           #+abcl sys::*module-provider-functions*
    3290            #+clozure ccl::*module-provider-functions*
     3392           #+clozure ccl:*module-provider-functions*
    32913393           #+cmu ext:*module-provider-functions*
    32923394           #+ecl si:*module-provider-functions*
    … …  
    33133415;;;; Done!
    33143416(when *load-verbose*
    3315   (asdf-message ";; ASDF, version ~a" (asdf-version)))
     3417  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
    33163418
    33173419#+allegro
    … …  
    33213423
    33223424(pushnew :asdf *features*)
    3323 ;; this is a release candidate for ASDF 2.0
    33243425(pushnew :asdf2 *features*)
    33253426
Note: See TracChangeset for help on using the changeset viewer.