Changeset 14789


Ignore:
Timestamp:
May 9, 2011, 10:12:10 AM (14 years ago)
Author:
R. Matthew Emerson
Message:

ASDF 2.015 from upstream.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/tools/asdf.lisp

    r14706 r14789  
    11;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.014: Another System Definition Facility.
     2;;; This is ASDF 2.015: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
    … …  
    2020;;;  Monday; July 13, 2009)
    2121;;;
    22 ;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
     22;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
    2323;;;
    2424;;; Permission is hereby granted, free of charge, to any person obtaining
    … …  
    5050(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
    5151
     52#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
     53(error "ASDF is not supported on your implementation. Please help us with it.")
     54
    5255#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
    5356
    5457(eval-when (:compile-toplevel :load-toplevel :execute)
    55   ;;; make package if it doesn't exist yet.
    56   ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
    57   (unless (find-package :asdf)
    58     (make-package :asdf :use '(:common-lisp)))
    5958  ;;; Implementation-dependent tweaks
    6059  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
    … …  
    6261  (setf excl::*autoload-package-name-alist*
    6362        (remove "asdf" excl::*autoload-package-name-alist*
    64                 :test 'equalp :key 'car))
     63                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    6564  #+(and ecl (not ecl-bytecmp)) (require :cmp)
    6665  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
    67   #+(or unix cygwin) (pushnew :asdf-unix *features*))
     66  #+(or unix cygwin) (pushnew :asdf-unix *features*)
     67  ;;; make package if it doesn't exist yet.
     68  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
     69  (unless (find-package :asdf)
     70    (make-package :asdf :use '(:common-lisp))))
    6871
    6972(in-package :asdf)
    70 
    71 ;;; Strip out formating that is not supported on Genera.
    72 (defmacro compatfmt (format)
    73   #-genera format
    74   #+genera
    75   (let ((r '(("~@<" . "")
    76              ("; ~@;" . "; ")
    77              ("~3i~_" . "")
    78              ("~@:>" . "")
    79              ("~:>" . ""))))
    80     (dolist (i r)
    81       (loop :for found = (search (car i) format) :while found :do
    82         (setf format (concatenate 'simple-string (subseq format 0 found)
    83                                   (cdr i)
    84                                   (subseq format (+ found (length (car i))))))))
    85     format))
    8673
    8774;;;; Create packages in a way that is compatible with hot-upgrade.
    … …  
    9279  (defvar *asdf-version* nil)
    9380  (defvar *upgraded-p* nil)
     81  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
     82  ;; Strip out formatting that is not supported on Genera.
     83  ;; Has to be inside the eval-when to make Lispworks happy (!)
     84  (defmacro compatfmt (format)
     85    #-genera format
     86    #+genera
     87    (loop :for (unsupported . replacement) :in
     88      '(("~@<" . "")
     89        ("; ~@;" . "; ")
     90        ("~3i~_" . "")
     91        ("~@:>" . "")
     92        ("~:>" . "")) :do
     93      (loop :for found = (search unsupported format) :while found :do
     94        (setf format
     95              (concatenate 'simple-string
     96                           (subseq format 0 found) replacement
     97                           (subseq format (+ found (length unsupported)))))))
     98    format)
    9499  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
    95100         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
    … …  
    100105         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    101106         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    102          (asdf-version "2.014")
     107         (asdf-version "2.015")
    103108         (existing-asdf (fboundp 'find-system))
    104109         (existing-version *asdf-version*)
    105110         (already-there (equal asdf-version existing-version)))
    106111    (unless (and existing-asdf already-there)
    107       (when existing-asdf
     112      (when (and existing-asdf *asdf-verbose*)
    108113        (format *trace-output*
    109                 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
    110                 existing-version asdf-version))
     114                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
     115                existing-version asdf-version))
    111116      (labels
    112117          ((present-symbol-p (symbol package)
    … …  
    148153             (let ((sym (find-sym symbol package)))
    149154               (when sym
    150                  (unexport sym package)
     155                 #-cormanlisp (unexport sym package)
    151156                 (unintern sym package)
    152157                 sym)))
    … …  
    214219            #:system-source-file #:operate #:find-component #:find-system
    215220            #:apply-output-translations #:translate-pathname* #:resolve-location
    216             #:compile-file*)
     221            #:compile-file* #:source-file-type)
    217222           :unintern
    218223           (#:*asdf-revision* #:around #:asdf-method-combination
    … …  
    226231           :export
    227232           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
    228             #:system-definition-pathname #:find-component ; miscellaneous
     233            #:system-definition-pathname
     234            #:search-for-system-definition #:find-component ; miscellaneous
    229235            #:compile-system #:load-system #:test-system #:clear-system
    230236            #:compile-op #:load-op #:load-source-op
    … …  
    234240            #:version                 ; metaphorically sort-of an operation
    235241            #:version-satisfies
     242            #:upgrade-asdf
     243            #:implementation-identifier #:implementation-type
    236244
    237245            #:input-files #:output-files #:output-file #:perform ; operation methods
    … …  
    240248            #:component #:source-file
    241249            #:c-source-file #:cl-source-file #:java-source-file
     250            #:cl-source-file.cl #:cl-source-file.lsp
    242251            #:static-file
    243252            #:doc-file
    … …  
    350359            #:truenamize
    351360            #:while-collecting)))
    352         #+genera (import 'scl:boolean :asdf)
     361        #+genera (import 'scl:boolean :asdf)
    353362        (setf *asdf-version* asdf-version
    354363              *upgraded-p* (if existing-version
    … …  
    362371  "Exported interface to the version of ASDF currently installed. A string.
    363372You can compare this string with e.g.:
    364 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")."
     373(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
    365374  *asdf-version*)
    366375
    … …  
    382391
    383392(defvar *verbose-out* nil)
    384 
    385 (defvar *asdf-verbose* t)
    386393
    387394(defparameter +asdf-methods+
    … …  
    397404
    398405;;;; -------------------------------------------------------------------------
     406;;;; Resolve forward references
     407
     408(declaim (ftype (function (t) t)
     409                format-arguments format-control
     410                error-name error-pathname error-condition
     411                duplicate-names-name
     412                error-component error-operation
     413                module-components module-components-by-name
     414                circular-dependency-components
     415                condition-arguments condition-form
     416                condition-format condition-location
     417                coerce-name)
     418         #-cormanlisp
     419         (ftype (function (t t) t) (setf module-components-by-name)))
     420
     421;;;; -------------------------------------------------------------------------
     422;;;; Compatibility with Corman Lisp
     423#+cormanlisp
     424(progn
     425  (deftype logical-pathname () nil)
     426  (defun make-broadcast-stream () *error-output*)
     427  (defun file-namestring (p)
     428    (setf p (pathname p))
     429    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
     430  (defparameter *count* 3)
     431  (defun dbg (&rest x)
     432    (format *error-output* "~S~%" x)))
     433#+cormanlisp
     434(defun maybe-break ()
     435  (decf *count*)
     436  (unless (plusp *count*)
     437    (setf *count* 3)
     438    (break)))
     439
     440;;;; -------------------------------------------------------------------------
    399441;;;; General Purpose Utilities
    400442
    … …  
    404446          `(progn
    405447             #+(or ecl gcl) (fmakunbound ',name)
    406              ,(when (and #+ecl (symbolp name))
    407                 `(declaim (notinline ,name))) ; fails for setf functions on ecl
     448             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
     449             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
     450                `(declaim (notinline ,name)))
    408451             (,',def ,name ,formals ,@rest)))))
    409452  (defdef defgeneric* defgeneric)
    … …  
    529572  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    530573
    531          
     574
    532575(defun* asdf-message (format-string &rest format-args)
    533576  (declare (dynamic-extent format-args))
    534   (apply #'format *verbose-out* format-string format-args))
     577  (apply 'format *verbose-out* format-string format-args))
    535578
    536579(defun* split-string (string &key max (separator '(#\Space #\Tab)))
    … …  
    540583starting the separation from the end, e.g. when called with arguments
    541584 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
    542   (block nil
     585  (catch nil
    543586    (let ((list nil) (words 0) (end (length string)))
    544587      (flet ((separatorp (char) (find char separator))
    545              (done () (return (cons (subseq string 0 end) list))))
     588             (done () (throw nil (cons (subseq string 0 end) list))))
    546589        (loop
    547590          :for start = (if (and max (>= words (1- max)))
    … …  
    623666(defun* getenv (x)
    624667  (declare (ignorable x))
    625   #+(or abcl clisp) (ext:getenv x)
     668  #+(or abcl clisp xcl) (ext:getenv x)
    626669  #+allegro (sys:getenv x)
    627670  #+clozure (ccl:getenv x)
    628671  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
     672  #+cormanlisp
     673  (let* ((buffer (ct:malloc 1))
     674         (cname (ct:lisp-string-to-c-string x))
     675         (needed-size (win:getenvironmentvariable cname buffer 0))
     676         (buffer1 (ct:malloc (1+ needed-size))))
     677    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
     678               nil
     679               (ct:c-string-to-lisp-string buffer1))
     680      (ct:free buffer)
     681      (ct:free buffer1)))
    629682  #+ecl (si:getenv x)
    630683  #+gcl (system:getenv x)
    … …  
    636689              (ccl:%get-cstring value))))
    637690  #+sbcl (sb-ext:posix-getenv x)
    638   #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)
    639   (error "getenv not available on your implementation"))
     691  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
     692  (error "~S is not supported on your implementation" 'getenv))
    640693
    641694(defun* directory-pathname-p (pathname)
    … …  
    713766  (defun* get-uid ()
    714767    #+allegro (excl.osi:getuid)
     768    #+ccl (ccl::getuid)
    715769    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
    716770                  :for f = (ignore-errors (read-from-string s))
    … …  
    721775                   '(ext::getuid))
    722776    #+sbcl (sb-unix:unix-getuid)
    723     #-(or allegro clisp cmu ecl sbcl scl)
     777    #-(or allegro ccl clisp cmu ecl sbcl scl)
    724778    (let ((uid-string
    725779           (with-output-to-string (*verbose-out*)
    … …  
    743797with given pathname and if it exists return its truename."
    744798  (etypecase p
    745    (null nil)
    746    (string (probe-file* (parse-namestring p)))
    747    (pathname (unless (wild-pathname-p p)
    748                #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
    749                      #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
    750                      '(ignore-errors (truename p)))))))
     799    (null nil)
     800    (string (probe-file* (parse-namestring p)))
     801    (pathname (unless (wild-pathname-p p)
     802                #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
     803                      #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
     804                      '(ignore-errors (truename p)))))))
    751805
    752806(defun* truenamize (p)
    … …  
    789843                (excl:pathname-resolve-symbolic-links path)))
    790844
     845(defun* resolve-symlinks* (path)
     846  (if *resolve-symlinks*
     847      (and path (resolve-symlinks path))
     848      path))
     849
     850(defun ensure-pathname-absolute (path)
     851  (cond
     852    ((absolute-pathname-p path) path)
     853    ((stringp path) (ensure-pathname-absolute (pathname path)))
     854    ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
     855    (t (let ((resolved (resolve-symlinks path)))
     856         (assert (absolute-pathname-p resolved))
     857         resolved))))
     858
    791859(defun* default-directory ()
    792860  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
    … …  
    795863  (make-pathname :type "lisp" :defaults input-file))
    796864
     865(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
    797866(defparameter *wild-file*
    798   (make-pathname :name :wild :type :wild :version :wild :directory nil))
     867  (make-pathname :name *wild* :type *wild* :version *wild* :directory nil))
    799868(defparameter *wild-directory*
    800   (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
     869  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
    801870(defparameter *wild-inferiors*
    802871  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
    … …  
    835904(defun* directorize-pathname-host-device (pathname)
    836905  (let ((scheme (ext:pathname-scheme pathname))
    837         (host (pathname-host pathname))
    838         (port (ext:pathname-port pathname))
    839         (directory (pathname-directory pathname)))
     906        (host (pathname-host pathname))
     907        (port (ext:pathname-port pathname))
     908        (directory (pathname-directory pathname)))
    840909    (flet ((not-unspecific (component)
    841              (and (not (eq component :unspecific)) component)))
     910             (and (not (eq component :unspecific)) component)))
    842911      (cond ((or (not-unspecific port)
    843                 (and (not-unspecific host) (plusp (length host)))
    844                 (not-unspecific scheme))
    845              (let ((prefix ""))
    846                (when (not-unspecific port)
    847                 (setf prefix (format nil ":~D" port)))
    848                (when (and (not-unspecific host) (plusp (length host)))
    849                 (setf prefix (concatenate 'string host prefix)))
    850                (setf prefix (concatenate 'string ":" prefix))
    851                (when (not-unspecific scheme)
    852                (setf prefix (concatenate 'string scheme prefix)))
    853                (assert (and directory (eq (first directory) :absolute)))
    854                (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
    855                               :defaults pathname)))
    856             (t
    857              pathname)))))
     912                (and (not-unspecific host) (plusp (length host)))
     913                (not-unspecific scheme))
     914             (let ((prefix ""))
     915               (when (not-unspecific port)
     916                (setf prefix (format nil ":~D" port)))
     917               (when (and (not-unspecific host) (plusp (length host)))
     918                (setf prefix (concatenate 'string host prefix)))
     919               (setf prefix (concatenate 'string ":" prefix))
     920               (when (not-unspecific scheme)
     921               (setf prefix (concatenate 'string scheme prefix)))
     922               (assert (and directory (eq (first directory) :absolute)))
     923               (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
     924                              :defaults pathname)))
     925            (t
     926             pathname)))))
    858927
    859928;;;; -------------------------------------------------------------------------
    … …  
    892961(defgeneric* (setf component-property) (new-value component property))
    893962
     963(eval-when (:compile-toplevel :load-toplevel :execute)
     964  (defgeneric* (setf module-components-by-name) (new-value module)))
     965
    894966(defgeneric* version-satisfies (component version))
    895967
    … …  
    9681040   (when (find-class 'module nil)
    9691041     (eval
    970       `(defmethod update-instance-for-redefined-class :after
     1042      '(defmethod update-instance-for-redefined-class :after
    9711043           ((m module) added deleted plist &key)
    9721044         (declare (ignorable deleted plist))
    973          (when (or *asdf-verbose* *load-verbose*)
     1045         (when *asdf-verbose*
    9741046           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
    975                          m ,(asdf-version)))
     1047                         m (asdf-version)))
    9761048         (when (member 'components-by-name added)
    9771049           (compute-module-components-by-name m))
    … …  
    9951067  #+cmu (:report print-object))
    9961068
    997 (declaim (ftype (function (t) t)
    998                 format-arguments format-control
    999                 error-name error-pathname error-condition
    1000                 duplicate-names-name
    1001                 error-component error-operation
    1002                 module-components module-components-by-name
    1003                 circular-dependency-components
    1004                 condition-arguments condition-form
    1005                 condition-format condition-location
    1006                 coerce-name)
    1007          (ftype (function (t t) t) (setf module-components-by-name)))
    1008 
    1009 
    10101069(define-condition formatted-system-definition-error (system-definition-error)
    10111070  ((format-control :initarg :format-control :reader format-control)
    10121071   (format-arguments :initarg :format-arguments :reader format-arguments))
    10131072  (:report (lambda (c s)
    1014                (apply #'format s (format-control c) (format-arguments c)))))
     1073               (apply 'format s (format-control c) (format-arguments c)))))
    10151074
    10161075(define-condition load-system-definition-error (system-definition-error)
    … …  
    10191078   (condition :initarg :condition :reader error-condition))
    10201079  (:report (lambda (c s)
    1021              (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
    1022                      (error-name c) (error-pathname c) (error-condition c)))))
     1080             (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
     1081                     (error-name c) (error-pathname c) (error-condition c)))))
    10231082
    10241083(define-condition circular-dependency (system-definition-error)
    10251084  ((components :initarg :components :reader circular-dependency-components))
    10261085  (:report (lambda (c s)
    1027              (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
    1028                      (circular-dependency-components c)))))
     1086             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
     1087                     (circular-dependency-components c)))))
    10291088
    10301089(define-condition duplicate-names (system-definition-error)
    10311090  ((name :initarg :name :reader duplicate-names-name))
    10321091  (:report (lambda (c s)
    1033              (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
    1034                      (duplicate-names-name c)))))
     1092             (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
     1093                     (duplicate-names-name c)))))
    10351094
    10361095(define-condition missing-component (system-definition-error)
    … …  
    10741133
    10751134(defclass component ()
    1076   ((name :accessor component-name :initarg :name :documentation
     1135  ((name :accessor component-name :initarg :name :type string :documentation
    10771136         "Component name: designator for a string composed of portable pathname characters")
    1078    (version :accessor component-version :initarg :version)
     1137   (version :accessor component-version :initarg :version) ;; :type (and string (satisfies parse-version)) -- not until we fix all systems that don't use it correctly!
    10791138   (description :accessor component-description :initarg :description)
    10801139   (long-description :accessor component-long-description :initarg :long-description)
    … …  
    11551214          (missing-version c)
    11561215          (when (missing-parent c)
    1157             (component-name (missing-parent c)))))
     1216            (coerce-name (missing-parent c)))))
    11581217
    11591218(defmethod component-system ((component component))
    … …  
    12451304(defmethod version-satisfies ((c component) version)
    12461305  (unless (and version (slot-boundp c 'version))
     1306    (when version
     1307      (warn "Requested version ~S but component ~S has no version" version c))
    12471308    (return-from version-satisfies t))
    12481309  (version-satisfies (component-version c) version))
    12491310
     1311(defun parse-version (string &optional on-error)
     1312  "Parse a version string as a series of natural integers separated by dots.
     1313Return a (non-null) list of integers if the string is valid, NIL otherwise.
     1314If on-error is error, warn, or designates a function of compatible signature,
     1315the function is called with an explanation of what is wrong with the argument.
     1316NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
     1317  (and
     1318   (or (stringp string)
     1319       (when on-error
     1320         (funcall on-error "~S: ~S is not a string"
     1321                  'parse-version string)) nil)
     1322   (or (loop :for prev = nil :then c :for c :across string
     1323         :always (or (digit-char-p c)
     1324                     (and (eql c #\.) prev (not (eql prev #\.))))
     1325         :finally (return (and c (digit-char-p c))))
     1326       (when on-error
     1327         (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
     1328                  'parse-version string)) nil)
     1329   (mapcar #'parse-integer (split-string string :separator "."))))
     1330
    12501331(defmethod version-satisfies ((cver string) version)
    1251   (let ((x (mapcar #'parse-integer
    1252                    (split-string cver :separator ".")))
    1253         (y (mapcar #'parse-integer
    1254                    (split-string version :separator "."))))
     1332  (let ((x (parse-version cver 'warn))
     1333        (y (parse-version version 'warn)))
    12551334    (labels ((bigger (x y)
    12561335               (cond ((not y) t)
    … …  
    12591338                     ((= (car x) (car y))
    12601339                      (bigger (cdr x) (cdr y))))))
    1261       (and (= (car x) (car y))
     1340      (and x y (= (car x) (car y))
    12621341           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    12631342
    … …  
    12851364  (gethash (coerce-name name) *defined-systems*))
    12861365
     1366(defun* register-system (system)
     1367  (check-type system system)
     1368  (let ((name (component-name system)))
     1369    (check-type name string)
     1370    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
     1371    (unless (eq system (cdr (gethash name *defined-systems*)))
     1372      (setf (gethash name *defined-systems*)
     1373            (cons (get-universal-time) system)))))
     1374
    12871375(defun* clear-system (name)
    12881376  "Clear the entry for a system in the database of systems previously loaded.
    12891377Note that this does NOT in any way cause the code of the system to be unloaded."
    1290   ;; There is no "unload" operation in Common Lisp, and a general such operation
    1291   ;; cannot be portably written, considering how much CL relies on side-effects
    1292   ;; to global data structures.
     1378  ;; There is no "unload" operation in Common Lisp, and
     1379  ;; a general such operation cannot be portably written,
     1380  ;; considering how much CL relies on side-effects to global data structures.
    12931381  (remhash (coerce-name name) *defined-systems*))
    12941382
    … …  
    13091397
    13101398(defparameter *system-definition-search-functions*
    1311   '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    1312 
    1313 (defun* system-definition-pathname (system)
     1399  '(sysdef-central-registry-search
     1400    sysdef-source-registry-search
     1401    sysdef-find-asdf))
     1402
     1403(defun* search-for-system-definition (system)
    13141404  (let ((system-name (coerce-name system)))
    1315     (or
    1316      (some #'(lambda (x) (funcall x system-name))
    1317            *system-definition-search-functions*)
    1318      (let ((system-pair (system-registered-p system-name)))
    1319        (and system-pair
    1320             (system-source-file (cdr system-pair)))))))
     1405    (some #'(lambda (x) (funcall x system-name))
     1406          *system-definition-search-functions*)))
    13211407
    13221408(defvar *central-registry* nil
    … …  
    13821468                          (coerce-entry-to-directory ()
    13831469                            :report (lambda (s)
    1384                                       (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
    1385                                               (ensure-directory-pathname defaults) dir))
     1470                                      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
     1471                                              (ensure-directory-pathname defaults) dir))
    13861472                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    13871473        ;; cleanup
    … …  
    14151501  ;; as if the file were very old.
    14161502  ;; (or should we treat the case in a different, special way?)
    1417   (or (and pathname (probe-file* pathname) (file-write-date pathname))
     1503  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
    14181504      (progn
    14191505        (when (and pathname *asdf-verbose*)
    … …  
    14211507                pathname))
    14221508        0)))
     1509
     1510(defmethod find-system ((name null) &optional (error-p t))
     1511  (when error-p
     1512    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
    14231513
    14241514(defmethod find-system (name &optional (error-p t))
    … …  
    14361526           (let ((*package* package))
    14371527             (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    1438                            pathname package)
     1528                           pathname package)
    14391529             (load pathname)))
    14401530      (delete-package package))))
    14411531
    14421532(defmethod find-system ((name string) &optional (error-p t))
    1443   (catch 'find-system
    1444     (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    1445            (on-disk (system-definition-pathname name)))
    1446       (when (and on-disk
    1447                  (or (not in-memory)
    1448                      ;; don't reload if it's already been loaded,
    1449                      ;; or its filestamp is in the future which means some clock is skewed
    1450                      ;; and trying to load might cause an infinite loop.
    1451                      (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time))))
    1452         (load-sysdef name on-disk))
    1453       (let ((in-memory (system-registered-p name))) ; try again after loading from disk
    1454         (cond
    1455           (in-memory
    1456            (when on-disk
    1457              (setf (car in-memory) (safe-file-write-date on-disk)))
    1458            (cdr in-memory))
    1459           (error-p
    1460            (error 'missing-component :requires name)))))))
    1461 
    1462 (defun* register-system (name system)
    1463   (setf name (coerce-name name))
    1464   (assert (equal name (component-name system)))
    1465   (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
    1466   (setf (gethash name *defined-systems*) (cons (get-universal-time) system)))
     1533  (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
     1534         (previous (cdr in-memory))
     1535         (previous (and (typep previous 'system) previous))
     1536         (previous-time (car in-memory))
     1537         (found (search-for-system-definition name))
     1538         (found-system (and (typep found 'system) found))
     1539         (pathname (or (and (typep found '(or pathname string)) (pathname found))
     1540                       (and found-system (system-source-file found-system))
     1541                       (and previous (system-source-file previous)))))
     1542    (setf pathname (resolve-symlinks* pathname))
     1543    (when (and pathname (not (absolute-pathname-p pathname)))
     1544      (setf pathname (ensure-pathname-absolute pathname))
     1545      (when found-system
     1546        (%set-system-source-file pathname found-system)))
     1547    (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
     1548                              (system-source-file previous) pathname)))
     1549      (%set-system-source-file pathname previous)
     1550      (setf previous-time nil))
     1551    (when (and found-system (not previous))
     1552      (register-system found-system))
     1553    (when (and pathname
     1554               (or (not previous-time)
     1555                   ;; don't reload if it's already been loaded,
     1556                   ;; or its filestamp is in the future which means some clock is skewed
     1557                   ;; and trying to load might cause an infinite loop.
     1558                   (< previous-time (safe-file-write-date pathname) (get-universal-time))))
     1559      (load-sysdef name pathname))
     1560    (let ((in-memory (system-registered-p name))) ; try again after loading from disk
     1561      (cond
     1562        (in-memory
     1563         (when pathname
     1564           (setf (car in-memory) (safe-file-write-date pathname)))
     1565         (cdr in-memory))
     1566        (error-p
     1567         (error 'missing-component :requires name))))))
    14671568
    14681569(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    14691570  (setf fallback (coerce-name fallback)
    1470         source-file (or source-file
    1471                         (if *resolve-symlinks*
    1472                             (or *compile-file-truename* *load-truename*)
    1473                             (or *compile-file-pathname* *load-pathname*)))
    14741571        requested (coerce-name requested))
    14751572  (when (equal requested fallback)
    1476     (let* ((registered (cdr (gethash fallback *defined-systems*)))
    1477            (system (or registered
    1478                        (apply 'make-instance 'system
    1479                               :name fallback :source-file source-file keys))))
    1480       (unless registered
    1481         (register-system fallback system))
    1482       (throw 'find-system system))))
     1573    (let ((registered (cdr (gethash fallback *defined-systems*))))
     1574      (or registered
     1575          (apply 'make-instance 'system
     1576                 :name fallback :source-file source-file keys)))))
    14831577
    14841578(defun* sysdef-find-asdf (name)
    … …  
    15241618(defclass cl-source-file (source-file)
    15251619  ((type :initform "lisp")))
     1620(defclass cl-source-file.cl (cl-source-file)
     1621  ((type :initform "cl")))
     1622(defclass cl-source-file.lsp (cl-source-file)
     1623  ((type :initform "lsp")))
    15261624(defclass c-source-file (source-file)
    15271625  ((type :initform "c")))
    … …  
    15731671             (t
    15741672              (split-name-type filename)))
    1575          (make-pathname :directory `(,relative ,@path) :name name :type type
    1576                         :defaults (or defaults *default-pathname-defaults*)))))))
     1673         (apply 'make-pathname :directory (cons relative path) :name name :type type
     1674                ;; XCL 0.0.0.291 and ABCL 0.25 have a bug, whereby make-pathname merges directories like merge-pathnames when a :defaults is provided. Fixed in the latest XCL.
     1675                (when defaults `(:defaults ,defaults))))))))
    15771676
    15781677(defun* merge-component-name-type (name &key type defaults)
    15791678  ;; For backwards compatibility only, for people using internals.
    1580   ;; Will be removed in a future release, e.g. 2.014.
     1679  ;; Will be removed in a future release, e.g. 2.016.
     1680  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
    15811681  (coerce-pathname name :type type :defaults defaults))
    15821682
    … …  
    15941694
    15951695(defclass operation ()
    1596   (
    1597    ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
    1598    ;; T to force the inside of existing system,
     1696  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
     1697   ;; T to force the inside of the specified system,
    15991698   ;;   but not recurse to other systems we depend on.
    16001699   ;; :ALL (or any other atom) to force all systems
    … …  
    16021701   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    16031702   ;;   to force systems named in a given list
    1604    ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
     1703   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
    16051704   (forced :initform nil :initarg :force :accessor operation-forced)
    16061705   (original-initargs :initform nil :initarg :original-initargs
    … …  
    16441743           (when (eql force-p t)
    16451744             (setf (getf args :force) nil))
    1646            (apply #'make-instance dep-o
     1745           (apply 'make-instance dep-o
    16471746                  :parent o
    16481747                  :original-initargs args args))
    … …  
    16501749           o)
    16511750          (t
    1652            (apply #'make-instance dep-o
     1751           (apply 'make-instance dep-o
    16531752                  :parent o :original-initargs args args)))))
    16541753
    … …  
    16821781
    16831782(defmethod component-depends-on ((op-spec symbol) (c component))
     1783  ;; Note: we go from op-spec to operation via make-instance
     1784  ;; to allow for specialization through defmethod's, even though
     1785  ;; it's a detour in the default case below.
    16841786  (component-depends-on (make-instance op-spec) c))
    16851787
    16861788(defmethod component-depends-on ((o operation) (c component))
    1687   (cdr (assoc (class-name (class-of o))
    1688               (component-in-order-to c))))
     1789  (cdr (assoc (type-of o) (component-in-order-to c))))
    16891790
    16901791(defmethod component-self-dependencies ((o operation) (c component))
    … …  
    18031904      (retry ()
    18041905        :report (lambda (s)
    1805                   (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c))
     1906                  (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
    18061907        :test
    18071908        (lambda (c)
    1808           (or (null c)
    1809               (and (typep c 'missing-dependency)
    1810                    (equalp (missing-requires c)
    1811                            required-c))))))))
     1909          (or (null c)
     1910              (and (typep c 'missing-dependency)
     1911                   (equalp (missing-requires c)
     1912                           required-c))))))))
    18121913
    18131914(defun* do-dep (operation c collect op dep)
    … …  
    18561957
    18571958(defmethod do-traverse ((operation operation) (c component) collect)
    1858   (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
     1959  (let ((*forcing* *forcing*)
     1960        (flag nil)) ;; return value: must we rebuild this and its dependencies?
    18591961    (labels
    18601962        ((update-flag (x)
    1861            (when x
    1862              (setf flag t)))
     1963           (orf flag x))
    18631964         (dep (op comp)
    18641965           (update-flag (do-dep operation c collect op comp))))
    … …  
    18741975      (unwind-protect
    18751976           (progn
     1977             (let ((f (operation-forced
     1978                       (operation-ancestor operation))))
     1979               (when (and f (or (not (consp f)) ;; T or :ALL
     1980                                (and (typep c 'system) ;; list of names of systems to force
     1981                                     (member (component-name c) f
     1982                                             :test #'string=))))
     1983                 (setf *forcing* t)))
    18761984             ;; first we check and do all the dependencies for the module.
    18771985             ;; Operations planned in this loop will show up
    … …  
    19132021                                     (not at-least-one))
    19142022                            (error error)))))))
    1915                (update-flag
    1916                 (or
    1917                  *forcing*
    1918                  (not (operation-done-p operation c))
     2023               (update-flag (or *forcing* (not (operation-done-p operation c))))
    19192024                 ;; For sub-operations, check whether
    19202025                 ;; the original ancestor operation was forced,
    … …  
    19232028                 ;; between all the things with a given name. Sigh.
    19242029                 ;; BROKEN!
    1925                  (let ((f (operation-forced
    1926                            (operation-ancestor operation))))
    1927                    (and f (or (not (consp f)) ;; T or :ALL
    1928                               (and (typep c 'system) ;; list of names of systems to force
    1929                                    (member (component-name c) f
    1930                                            :test #'string=)))))))
    19312030               (when flag
    19322031                 (let ((do-first (cdr (assoc (class-name (class-of operation))
    … …  
    19572056
    19582057(defmethod traverse ((operation operation) (c component))
    1959   ;; cerror'ing a feature that seems to have NEVER EVER worked
    1960   ;; ever since danb created it in his 2003-03-16 commit e0d02781.
    1961   ;; It was both fixed and disabled in the 1.700 rewrite.
    19622058  (when (consp (operation-forced operation))
    1963     (cerror "Continue nonetheless."
    1964             "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.")
    19652059    (setf (operation-forced operation)
    19662060          (mapcar #'coerce-name (operation-forced operation))))
    … …  
    19802074
    19812075(defmethod explain ((operation operation) (component component))
    1982   (asdf-message "~&;;; ~A~%" (operation-description operation component)))
     2076  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
     2077                (operation-description operation component)))
    19832078
    19842079(defmethod operation-description (operation component)
    1985   (format nil (compatfmt "~@<~A on component ~S~@:>")
    1986           (class-of operation) (component-find-path component)))
     2080  (format nil (compatfmt "~@<~A on ~A~@:>")
     2081          (class-of operation) component))
    19872082
    19882083;;;; -------------------------------------------------------------------------
    … …  
    20682163(defmethod operation-description ((operation compile-op) component)
    20692164  (declare (ignorable operation))
    2070   (format nil "compiling component ~S" (component-find-path component)))
     2165  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
     2166
     2167(defmethod operation-description ((operation compile-op) (component module))
     2168  (declare (ignorable operation))
     2169  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
     2170
    20712171
    20722172;;;; -------------------------------------------------------------------------
    … …  
    20812181
    20822182(defmethod perform-with-restarts (operation component)
     2183  ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
    20832184  (perform operation component))
    20842185
    … …  
    20952196      (:failed-load
    20962197       (setf state :recompiled)
    2097        (perform (make-instance 'compile-op) c))
     2198       (perform (make-sub-operation c o c 'compile-op) c))
    20982199      (t
    20992200       (with-simple-restart
    … …  
    21432244(defmethod operation-description ((operation load-op) component)
    21442245  (declare (ignorable operation))
    2145   (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
    2146           (component-find-path component)))
    2147 
     2246  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
     2247          component))
     2248
     2249(defmethod operation-description ((operation load-op) (component cl-source-file))
     2250  (declare (ignorable operation))
     2251  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
     2252          component))
     2253
     2254(defmethod operation-description ((operation load-op) (component module))
     2255  (declare (ignorable operation))
     2256  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
     2257          component))
    21482258
    21492259;;;; -------------------------------------------------------------------------
    … …  
    21702280(defmethod component-depends-on ((o load-source-op) (c component))
    21712281  (declare (ignorable o))
    2172   (let ((what-would-load-op-do (cdr (assoc 'load-op
    2173                                            (component-in-order-to c)))))
    2174     (mapcar #'(lambda (dep)
    2175                 (if (eq (car dep) 'load-op)
    2176                     (cons 'load-source-op (cdr dep))
    2177                     dep))
    2178             what-would-load-op-do)))
     2282  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
     2283    :for (op co) :in what-would-load-op-do
     2284    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
    21792285
    21802286(defmethod operation-done-p ((o load-source-op) (c source-file))
    … …  
    21872293(defmethod operation-description ((operation load-source-op) component)
    21882294  (declare (ignorable operation))
    2189   (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
    2190           (component-find-path component)))
     2295  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
     2296          component))
     2297
     2298(defmethod operation-description ((operation load-source-op) (component module))
     2299  (declare (ignorable operation))
     2300  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
    21912301
    21922302
    … …  
    22142324
    22152325(defgeneric* operate (operation-class system &key &allow-other-keys))
     2326(defgeneric* perform-plan (plan &key))
     2327
     2328;;;; Try to upgrade of ASDF. If a different version was used, return T.
     2329;;;; We need do that before we operate on anything that depends on ASDF.
     2330(defun* upgrade-asdf ()
     2331  (let ((version (asdf:asdf-version)))
     2332    (handler-bind (((or style-warning warning) #'muffle-warning))
     2333      (operate 'load-op :asdf :verbose nil))
     2334    (let ((new-version (asdf:asdf-version)))
     2335      (block nil
     2336        (cond
     2337          ((equal version new-version)
     2338           (return nil))
     2339          ((version-satisfies new-version version)
     2340           (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
     2341                         version new-version))
     2342          ((version-satisfies version new-version)
     2343           (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
     2344                 version new-version))
     2345          (t
     2346           (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
     2347                         version new-version)))
     2348        (let ((asdf (find-system :asdf)))
     2349          ;; invalidate all systems but ASDF itself
     2350          (setf *defined-systems* (make-defined-systems-table))
     2351          (register-system asdf)
     2352          t)))))
     2353
     2354(defmethod perform-plan ((steps list) &key)
     2355  (let ((*package* *package*)
     2356        (*readtable* *readtable*))
     2357    (with-compilation-unit ()
     2358      (loop :for (op . component) :in steps :do
     2359        (loop
     2360          (restart-case
     2361              (progn
     2362                (perform-with-restarts op component)
     2363                (return))
     2364            (retry ()
     2365              :report
     2366              (lambda (s)
     2367                (format s (compatfmt "~@<Retry ~A.~@:>")
     2368                        (operation-description op component))))
     2369            (accept ()
     2370              :report
     2371              (lambda (s)
     2372                (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
     2373                        (operation-description op component)))
     2374              (setf (gethash (type-of op)
     2375                             (component-operation-times component))
     2376                    (get-universal-time))
     2377              (return))))))))
    22162378
    22172379(defmethod operate (operation-class system &rest args
    … …  
    22192381                    &allow-other-keys)
    22202382  (declare (ignore force))
    2221   (let* ((*package* *package*)
    2222          (*readtable* *readtable*)
    2223          (op (apply #'make-instance operation-class
     2383  (let* ((op (apply 'make-instance operation-class
    22242384                    :original-initargs args
    22252385                    args))
    22262386         (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
    2227          (system (if (typep system 'component) system (find-system system))))
     2387         (system (etypecase system
     2388                   (system system)
     2389                   ((or string symbol) (find-system system)))))
    22282390    (unless (version-satisfies system version)
    22292391      (error 'missing-component-of-version :requires system :version version))
    22302392    (let ((steps (traverse op system)))
    2231       (with-compilation-unit ()
    2232         (loop :for (op . component) :in steps :do
    2233           (loop
    2234             (restart-case
    2235                 (progn
    2236                   (perform-with-restarts op component)
    2237                   (return))
    2238               (retry ()
    2239                 :report
    2240                 (lambda (s)
    2241                   (format s (compatfmt "~@<Retry ~A.~@:>")
    2242                           (operation-description op component))))
    2243               (accept ()
    2244                 :report
    2245                 (lambda (s)
    2246                   (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
    2247                           (operation-description op component)))
    2248                 (setf (gethash (type-of op)
    2249                                (component-operation-times component))
    2250                       (get-universal-time))
    2251                 (return))))))
     2393      (when (and (not (equal '("asdf") (component-find-path system)))
     2394                 (find-if #'(lambda (x) (equal '("asdf")
     2395                                               (component-find-path (cdr x))))
     2396                          steps)
     2397                 (upgrade-asdf))
     2398        ;; If we needed to upgrade ASDF to achieve our goal,
     2399        ;; then do it specially as the first thing, then
     2400        ;; invalidate all existing system
     2401        ;; retry the whole thing with the new OPERATE function,
     2402        ;; which on some implementations
     2403        ;; has a new symbol shadowing the current one.
     2404        (return-from operate
     2405          (apply (find-symbol* 'operate :asdf) operation-class system args)))
     2406      (perform-plan steps)
    22522407      (values op steps))))
    22532408
    … …  
    22552410            &allow-other-keys)
    22562411  (declare (ignore force verbose version))
    2257   (apply #'operate operation-class system args))
     2412  (apply 'operate operation-class system args))
    22582413
    22592414(let ((operate-docstring
    … …  
    22822437        operate-docstring))
    22832438
    2284 (defun* load-system (system &rest args &key force verbose version
    2285                     &allow-other-keys)
    2286   "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
    2287 details."
     2439(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
     2440  "Shorthand for `(operate 'asdf:load-op system)`.
     2441See OPERATE for details."
    22882442  (declare (ignore force verbose version))
    2289   (apply #'operate 'load-op system args)
     2443  (apply 'operate 'load-op system args)
    22902444  t)
    22912445
    … …  
    22952449for details."
    22962450  (declare (ignore force verbose version))
    2297   (apply #'operate 'compile-op system args)
     2451  (apply 'operate 'compile-op system args)
    22982452  t)
    22992453
    … …  
    23032457details."
    23042458  (declare (ignore force verbose version))
    2305   (apply #'operate 'test-op system args)
     2459  (apply 'operate 'test-op system args)
    23062460  t)
    23072461
    … …  
    23102464
    23112465(defun* load-pathname ()
    2312   (let ((pn (or *load-pathname* *compile-file-pathname*)))
    2313     (if *resolve-symlinks*
    2314         (and pn (resolve-symlinks pn))
    2315         pn)))
     2466  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
    23162467
    23172468(defun* determine-system-pathname (pathname pathname-supplied-p)
    … …  
    23472498                  (change-class (cdr s) ',class))
    23482499                 (t
    2349                   (register-system (quote ,name)
    2350                                    (make-instance ',class :name ',name))))
     2500                  (register-system (make-instance ',class :name ',name))))
    23512501           (%set-system-source-file (load-pathname)
    23522502                                    (cdr (system-registered-p ',name))))
    … …  
    23642514                             (find-symbol* type :asdf))
    23652515        :for class = (and symbol (find-class symbol nil))
    2366         :when (and class (subtypep class 'component))
     2516        :when (and class
     2517                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
     2518                                 class (find-class 'component)))
    23672519        :return class)
    23682520      (and (eq type :file)
    … …  
    24592611              weakly-depends-on
    24602612              depends-on serial in-order-to
     2613              (version nil versionp)
    24612614              ;; list ends
    24622615              &allow-other-keys) options
    … …  
    24712624                       (class-for-type parent type))))
    24722625      (error 'duplicate-names :name name))
     2626
     2627    (when versionp
     2628      (unless (parse-version version nil)
     2629        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
     2630              version name parent)))
    24732631
    24742632    (let* ((other-args (remove-keys
    … …  
    24852643      (when *serial-depends-on*
    24862644        (push *serial-depends-on* depends-on))
    2487       (apply #'reinitialize-instance ret
     2645      (apply 'reinitialize-instance ret
    24882646             :name (coerce-name name)
    24892647             :pathname pathname
    … …  
    25352693synchronously execute the result using a Bourne-compatible shell, with
    25362694output to *VERBOSE-OUT*.  Returns the shell's exit code."
    2537   (let ((command (apply #'format nil control-string args)))
     2695  (let ((command (apply 'format nil control-string args)))
    25382696    (asdf-message "; $ ~A~%" command)
    25392697
    … …  
    25532711      exit-code)
    25542712
    2555     #+clisp                     ;XXX not exactly *verbose-out*, I know
    2556     (or (ext:run-shell-command  command :output :terminal :wait t) 0)
     2713    #+clisp                    ;XXX not exactly *verbose-out*, I know
     2714    (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
    25572715
    25582716    #+clozure
    … …  
    25792737    #+sbcl
    25802738    (sb-ext:process-exit-code
    2581      (apply #'sb-ext:run-program
     2739     (apply 'sb-ext:run-program
    25822740            #+win32 "sh" #-win32 "/bin/sh"
    25832741            (list  "-c" command)
    … …  
    25922750      :input nil :output *verbose-out*))
    25932751
    2594     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
     2752    #+xcl
     2753    (ext:run-shell-command command)
     2754
     2755    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
    25952756    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
    25962757
    25972758;;;; ---------------------------------------------------------------------------
    25982759;;;; system-relative-pathname
     2760
     2761(defun* system-definition-pathname (x)
     2762  ;; As of 2.014.8, we mean to make this function obsolete,
     2763  ;; but that won't happen until all clients have been updated.
     2764  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
     2765  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
     2766It used to expose ASDF internals with subtle differences with respect to
     2767user expectations, that have been refactored away since.
     2768We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
     2769for a mostly compatible replacement that we're supporting,
     2770or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
     2771if that's whay you mean." ;;)
     2772  (system-source-file x))
    25992773
    26002774(defmethod system-source-file ((system-name string))
    … …  
    26452819    (:corman :cormanlisp)
    26462820    (:lw :lispworks)
    2647     :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
     2821    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
    26482822
    26492823(defparameter *os-features*
    … …  
    26592833  '((:amd64 :x86-64 :x86_64 :x8664-target)
    26602834    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
    2661     :hppa64
    2662     :hppa
    2663     (:ppc64 :ppc64-target)
    2664     (:ppc32 :ppc32-target :ppc :powerpc)
    2665     :sparc64
    2666     (:sparc32 :sparc)
     2835    :hppa64 :hppa
     2836    (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
     2837    :sparc64 (:sparc32 :sparc)
    26672838    (:arm :arm-target)
    26682839    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
     2840    :mipsel :mipseb :mips
     2841    :alpha
    26692842    :imach))
    26702843
    … …  
    27292902      ((maybe-warn (value fstring &rest args)
    27302903         (cond (value)
    2731                (t (apply #'warn fstring args)
     2904               (t (apply 'warn fstring args)
    27322905                  "unknown"))))
    27332906    (let ((lisp (maybe-warn (implementation-type)
    … …  
    28463019    (unless (length=n-p forms 1)
    28473020      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
    2848              description forms))
     3021             description forms))
    28493022    (funcall validator (car forms) :location file)))
    28503023
    … …  
    31023275           (when inherit
    31033276             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    3104                     string))
     3277                    string))
    31053278           (setf inherit t)
    31063279           (push :inherit-configuration directives))
    … …  
    31113284          (when source
    31123285            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
    3113                    string))
     3286                   string))
    31143287          (unless inherit
    31153288            (push :ignore-inherited-configuration directives))
    … …  
    31433316
    31443317(defun* user-output-translations-pathname ()
    3145   (in-user-configuration-directory *output-translations-file* ))
     3318  (in-user-configuration-directory *output-translations-file*))
    31463319(defun* system-output-translations-pathname ()
    31473320  (in-system-configuration-directory *output-translations-file*))
    … …  
    32723445(defun* apply-output-translations (path)
    32733446  (etypecase path
     3447    #+cormanlisp (t (truenamize path))
    32743448    (logical-pathname
    32753449     path)
    … …  
    34903664(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    34913665
    3492 (defvar *source-registry* ()
    3493   "Either NIL (for uninitialized), or a list of one element,
    3494 said element itself being a list of directory pathnames where to look for .asd files")
    3495 
    3496 (defun* source-registry ()
    3497   (car *source-registry*))
    3498 
    3499 (defun* (setf source-registry) (new-value)
    3500   (setf *source-registry* (list new-value))
    3501   new-value)
     3666(defvar *source-registry* nil
     3667  "Either NIL (for uninitialized), or an equal hash-table, mapping
     3668system names to pathnames of .asd files")
    35023669
    35033670(defun* source-registry-initialized-p ()
    3504   (and *source-registry* t))
     3671  (typep *source-registry* 'hash-table))
    35053672
    35063673(defun* clear-source-registry ()
    … …  
    35083675You might want to call that before you dump an image that would be resumed
    35093676with a different configuration, so the configuration would be re-read then."
    3510   (setf *source-registry* '())
     3677  (setf *source-registry* nil)
    35113678  (values))
    35123679
    35133680(defparameter *wild-asd*
    3514   (make-pathname :directory nil :name :wild :type "asd" :version :newest))
    3515 
    3516 (defun directory-has-asd-files-p (directory)
     3681  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
     3682
     3683(defun directory-asd-files (directory)
    35173684  (ignore-errors
    3518     (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
     3685    (directory* (merge-pathnames* *wild-asd* directory))))
    35193686
    35203687(defun subdirectories (directory)
    35213688  (let* ((directory (ensure-directory-pathname directory))
    3522          #-(or cormanlisp genera)
     3689         #-(or cormanlisp genera xcl)
    35233690         (wild (merge-pathnames*
    3524                 #-(or abcl allegro lispworks scl)
     3691                #-(or abcl allegro cmu lispworks scl xcl)
    35253692                *wild-directory*
    3526                 #+(or abcl allegro lispworks scl) "*.*"
     3693                #+(or abcl allegro cmu lispworks scl xcl) "*.*"
    35273694                directory))
    35283695         (dirs
    3529           #-(or cormanlisp genera)
     3696          #-(or cormanlisp genera xcl)
    35303697          (ignore-errors
    35313698            (directory* wild . #.(or #+clozure '(:directories t :files nil)
    35323699                                     #+mcl '(:directories t))))
    35333700          #+cormanlisp (cl::directory-subdirs directory)
    3534           #+genera (fs:directory-list directory))
    3535          #+(or abcl allegro genera lispworks scl)
    3536          (dirs (remove-if-not #+abcl #'extensions:probe-directory
    3537                               #+allegro #'excl:probe-directory
    3538                               #+lispworks #'lw:file-directory-p
    3539                               #+genera #'(lambda (x) (getf (cdr x) :directory))
    3540                               #-(or abcl allegro genera lispworks) #'directory-pathname-p
    3541                               dirs))
    3542          #+genera
    3543          (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs)))
     3701          #+genera (fs:directory-list directory)
     3702          #+xcl (system:list-directory directory))
     3703         #+(or abcl allegro cmu genera lispworks scl xcl)
     3704         (dirs (loop :for x :in dirs
     3705                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
     3706                          #+allegro (excl:probe-directory x)
     3707                          #+(or cmu scl) (directory-pathname-p x)
     3708                          #+genera (getf (cdr x) :directory)
     3709                          #+lispworks (lw:file-directory-p x)
     3710                 :when d :collect #+(or abcl allegro xcl) d
     3711                                  #+genera (ensure-directory-pathname (first x))
     3712                                  #+(or cmu lispworks scl) x)))
    35443713    dirs))
     3714
     3715(defun collect-asds-in-directory (directory collect)
     3716  (map () collect (directory-asd-files directory)))
    35453717
    35463718(defun collect-sub*directories (directory collectp recursep collector)
    … …  
    35513723      (collect-sub*directories subdir collectp recursep collector))))
    35523724
    3553 (defun collect-sub*directories-with-asd
     3725(defun collect-sub*directories-asd-files
    35543726    (directory &key
    35553727     (exclude *default-source-registry-exclusions*)
    … …  
    35573729  (collect-sub*directories
    35583730   directory
    3559    #'directory-has-asd-files-p
     3731   (constantly t)
    35603732   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
    3561    collect))
     3733   #'(lambda (dir) (collect-asds-in-directory dir collect))))
    35623734
    35633735(defun* validate-source-registry-directive (directive)
    … …  
    36083780          (when inherit
    36093781            (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    3610                    string))
     3782                   string))
    36113783          (setf inherit t)
    36123784          (push ':inherit-configuration directives))
    … …  
    36253797(defun* register-asd-directory (directory &key recurse exclude collect)
    36263798  (if (not recurse)
    3627       (funcall collect directory)
    3628       (collect-sub*directories-with-asd
     3799      (collect-asds-in-directory directory collect)
     3800      (collect-sub*directories-asd-files
    36293801       directory :exclude exclude :collect collect)))
    36303802
    … …  
    37583930;; Will read the configuration and initialize all internal variables,
    37593931;; and return the new configuration.
    3760 (defun* compute-source-registry (&optional parameter)
    3761   (while-collecting (collect)
    3762     (dolist (entry (flatten-source-registry parameter))
    3763       (destructuring-bind (directory &key recurse exclude) entry
     3932(defun* compute-source-registry (&optional parameter (registry *source-registry*))
     3933  (dolist (entry (flatten-source-registry parameter))
     3934    (destructuring-bind (directory &key recurse exclude) entry
     3935      (let* ((h (make-hash-table :test 'equal)))
    37643936        (register-asd-directory
    3765          directory
    3766          :recurse recurse :exclude exclude :collect #'collect)))))
     3937         directory :recurse recurse :exclude exclude :collect
     3938         #'(lambda (asd)
     3939             (let ((name (pathname-name asd)))
     3940               (cond
     3941                 ((gethash name registry) ; already shadowed by something else
     3942                  nil)
     3943                 ((gethash name h) ; conflict at current level
     3944                  (when *asdf-verbose*
     3945                    (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
     3946                                found several entries for ~A - picking ~S over ~S~:>")
     3947                          directory recurse name (gethash name h) asd)))
     3948                 (t
     3949                  (setf (gethash name registry) asd)
     3950                  (setf (gethash name h) asd))))))
     3951        h)))
     3952  (values))
    37673953
    37683954(defvar *source-registry-parameter* nil)
    37693955
    37703956(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
    3771   (setf *source-registry-parameter* parameter
    3772         (source-registry) (compute-source-registry parameter)))
     3957  (setf *source-registry-parameter* parameter)
     3958  (setf *source-registry* (make-hash-table :test 'equal))
     3959  (compute-source-registry parameter))
    37733960
    37743961;; Checks an initial variable to see whether the state is initialized
    … …  
    37813968;; initialize-source-registry directly with your parameter.
    37823969(defun* ensure-source-registry (&optional parameter)
    3783   (if (source-registry-initialized-p)
    3784       (source-registry)
    3785       (initialize-source-registry parameter)))
     3970  (unless (source-registry-initialized-p)
     3971    (initialize-source-registry parameter))
     3972  (values))
    37863973
    37873974(defun* sysdef-source-registry-search (system)
    37883975  (ensure-source-registry)
    3789   (loop :with name = (coerce-name system)
    3790     :for defaults :in (source-registry)
    3791     :for file = (probe-asd name defaults)
    3792     :when file :return file))
     3976  (values (gethash (coerce-name system) *source-registry*)))
    37933977
    37943978(defun* clear-configuration ()
    … …  
    37963980  (clear-output-translations))
    37973981
     3982
     3983;;; ECL support for COMPILE-OP / LOAD-OP
     3984;;;
     3985;;; In ECL, these operations produce both FASL files and the
     3986;;; object files that they are built from. Having both of them allows
     3987;;; us to later on reuse the object files for bundles, libraries,
     3988;;; standalone executables, etc.
     3989;;;
     3990;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
     3991;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
     3992;;;
     3993#+ecl
     3994(progn
     3995  (setf *compile-op-compile-file-function*
     3996        (lambda (input-file &rest keys &key output-file &allow-other-keys)
     3997          (declare (ignore output-file))
     3998          (multiple-value-bind (object-file flags1 flags2)
     3999              (apply 'compile-file* input-file :system-p t keys)
     4000            (values (and object-file
     4001                         (c::build-fasl (compile-file-pathname object-file :type :fasl)
     4002                                        :lisp-files (list object-file))
     4003                         object-file)
     4004                    flags1
     4005                    flags2))))
     4006
     4007  (defmethod output-files ((operation compile-op) (c cl-source-file))
     4008    (declare (ignorable operation))
     4009    (let ((p (lispize-pathname (component-pathname c))))
     4010      (list (compile-file-pathname p :type :object)
     4011            (compile-file-pathname p :type :fasl))))
     4012
     4013  (defmethod perform ((o load-op) (c cl-source-file))
     4014    (map () #'load
     4015         (loop :for i :in (input-files o c)
     4016           :unless (string= (pathname-type i) "fas")
     4017           :collect (compile-file-pathname (lispize-pathname i))))))
     4018
    37984019;;;; -----------------------------------------------------------------
    37994020;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
    38004021;;;;
     4022(defvar *require-asdf-operator* 'load-op)
     4023
    38014024(defun* module-provide-asdf (name)
    38024025  (handler-bind
    … …  
    38074030                          name e))))
    38084031    (let ((*verbose-out* (make-broadcast-stream))
    3809            (system (find-system (string-downcase name) nil)))
     4032          (system (find-system (string-downcase name) nil)))
    38104033      (when system
    3811         (load-system system)))))
     4034        (operate *require-asdf-operator* system :verbose nil)
     4035        t))))
    38124036
    38134037#+(or abcl clisp clozure cmu ecl sbcl)
Note: See TracChangeset for help on using the changeset viewer.