Changeset 15414


Ignore:
Timestamp:
Jun 13, 2012, 8:02:40 PM (7 years ago)
Author:
rme
Message:

Update to ASDF 2.22.

File:
1 edited

Legend:

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

    r15207 r15414  
    1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.20: Another System Definition Facility.
     1;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
     2;;; This is ASDF 2.22: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    2020;;;  Monday; July 13, 2009)
    2121;;;
    22 ;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
     22;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
    2323;;;
    2424;;; Permission is hereby granted, free of charge, to any person obtaining
     
    4848#+xcvb (module ())
    4949
    50 (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
     50(cl:in-package :common-lisp-user)
     51#+genera (in-package :future-common-lisp-user)
    5152
    5253#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
    5354(error "ASDF is not supported on your implementation. Please help us port it.")
    5455
     56;;;; Create and setup packages in a way that is compatible with hot-upgrade.
     57;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     58;;;; See these two eval-when forms, and more near the end of the file.
     59
    5560#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
    5661
    57 (eval-when (:compile-toplevel :load-toplevel :execute)
    58   ;;; Implementation-dependent tweaks
     62(eval-when (:load-toplevel :compile-toplevel :execute)
     63  ;;; Before we do anything, some implementation-dependent tweaks
    5964  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
    6065  #+allegro
     
    6267        (remove "asdf" excl::*autoload-package-name-alist*
    6368                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    64   #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
    65   #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
    6669  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
    6770  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
     
    6972                 (< system::*gcl-minor-version* 7)))
    7073    (pushnew :gcl-pre2.7 *features*))
     74  #+(or abcl (and allegro ics) (and clisp unicode) clozure (and cmu unicode)
     75        (and ecl unicode) lispworks (and sbcl sb-unicode) scl)
     76  (pushnew :asdf-unicode *features*)
    7177  ;;; make package if it doesn't exist yet.
    7278  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
     
    7682(in-package :asdf)
    7783
    78 ;;;; Create packages in a way that is compatible with hot-upgrade.
    79 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    80 ;;;; See more near the end of the file.
    81 
    8284(eval-when (:load-toplevel :compile-toplevel :execute)
     85  ;;; This would belong amongst implementation-dependent tweaks above,
     86  ;;; except that the defun has to be in package asdf.
     87  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
     88  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
     89
     90  ;;; Package setup, step 2.
    8391  (defvar *asdf-version* nil)
    8492  (defvar *upgraded-p* nil)
     
    109117         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    110118         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    111          (asdf-version "2.20")
     119         (asdf-version "2.22")
    112120         (existing-asdf (find-class 'component nil))
    113121         (existing-version *asdf-version*)
     
    169177             (shadow symbols package))
    170178           (ensure-use (package use)
     179             (dolist (used (package-use-list package))
     180               (unless (member (package-name used) use :test 'string=)
     181                 (unuse-package used)
     182                 (do-external-symbols (sym used)
     183                   (when (eq sym (find-symbol* sym package))
     184                     (remove-symbol sym package)))))
    171185             (dolist (used (reverse use))
    172186               (do-external-symbols (sym used)
     
    200214                                 shadow export redefined-functions)
    201215             (let* ((p (ensure-exists name nicknames use)))
    202                (ensure-unintern p unintern)
     216               (ensure-unintern p (append unintern #+cmu redefined-functions))
    203217               (ensure-shadow p shadow)
    204218               (ensure-export p export)
    205                (ensure-fmakunbound p redefined-functions)
     219               #-cmu (ensure-fmakunbound p redefined-functions)
    206220               p)))
    207221        (macrolet
     
    235249            #:system-definition-pathname #:with-system-definitions
    236250            #:search-for-system-definition #:find-component #:component-find-path
    237             #:compile-system #:load-system #:load-systems #:test-system #:clear-system
     251            #:compile-system #:load-system #:load-systems
     252            #:require-system #:test-system #:clear-system
    238253            #:operation #:compile-op #:load-op #:load-source-op #:test-op
    239254            #:feature #:version #:version-satisfies
    240255            #:upgrade-asdf
    241             #:implementation-identifier #:implementation-type
     256            #:implementation-identifier #:implementation-type #:hostname
    242257            #:input-files #:output-files #:output-file #:perform
    243258            #:operation-done-p #:explain
     
    256271
    257272            #:module-components          ; component accessors
    258             #:module-components-by-name  ; component accessors
     273            #:module-components-by-name
    259274            #:component-pathname
    260275            #:component-relative-pathname
     
    264279            #:component-property
    265280            #:component-system
    266 
    267281            #:component-depends-on
     282            #:component-encoding
     283            #:component-external-format
    268284
    269285            #:system-description
     
    282298            #:operation-on-failure
    283299            #:component-visited-p
    284             ;;#:*component-parent-pathname*
    285             #:*system-definition-search-functions*
    286             #:*central-registry*         ; variables
     300
     301            #:*system-definition-search-functions*   ; variables
     302            #:*central-registry*
    287303            #:*compile-file-warnings-behaviour*
    288304            #:*compile-file-failure-behaviour*
     
    312328            #:coerce-entry-to-directory
    313329            #:remove-entry-from-registry
     330
     331            #:*encoding-detection-hook*
     332            #:*encoding-external-format-hook*
     333            #:*default-encoding*
     334            #:*utf-8-external-format*
    314335
    315336            #:clear-configuration
     
    330351            #:ensure-source-registry
    331352            #:process-source-registry
    332             #:system-registered-p
     353            #:system-registered-p #:registered-systems #:loaded-systems
     354            #:resolve-location
    333355            #:asdf-message
    334356            #:user-output-translations-pathname
     
    342364
    343365            ;; Utilities
    344             #:absolute-pathname-p
    345366            ;; #:aif #:it
    346             ;; #:appendf #:orf
     367            #:appendf #:orf
     368            #:length=n-p
     369            #:remove-keys #:remove-keyword
     370            #:first-char #:last-char #:ends-with
    347371            #:coerce-name
    348             #:directory-pathname-p
    349             ;; #:ends-with
    350             #:ensure-directory-pathname
     372            #:directory-pathname-p #:ensure-directory-pathname
     373            #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
    351374            #:getenv
    352             ;; #:length=n-p
    353             ;; #:find-symbol*
    354             #:merge-pathnames* #:coerce-pathname #:subpathname
    355             #:pathname-directory-pathname
     375            #:probe-file*
     376            #:find-symbol* #:strcat
     377            #:make-pathname-component-logical #:make-pathname-logical
     378            #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname*
     379            #:pathname-directory-pathname #:pathname-parent-directory-pathname
    356380            #:read-file-forms
    357             ;; #:remove-keys
    358             ;; #:remove-keyword
    359             #:resolve-symlinks
     381            #:resolve-symlinks #:truenamize
    360382            #:split-string
    361383            #:component-name-to-pathname-components
    362384            #:split-name-type
    363             #:subdirectories
    364             #:truenamize
    365             #:while-collecting)))
     385            #:subdirectories #:directory-files
     386            #:while-collecting
     387            #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
     388            #:*wild-path* #:wilden
     389            #:directorize-pathname-host-device
     390            )))
    366391        #+genera (import 'scl:boolean :asdf)
    367392        (setf *asdf-version* asdf-version
     
    482507
    483508(defmacro aif (test then &optional else)
     509  "Anaphoric version of IF, On Lisp style"
    484510  `(let ((it ,test)) (if it ,then ,else)))
    485511
     
    491517
    492518(defun* normalize-pathname-directory-component (directory)
     519  "Given a pathname directory component, return an equivalent form that is a list"
    493520  (cond
    494     #-(or cmu sbcl scl)
     521    #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
    495522    ((stringp directory) `(:absolute ,directory) directory)
    496523    #+gcl
     
    504531
    505532(defun* merge-pathname-directory-components (specified defaults)
     533  ;; Helper for merge-pathnames* that handles directory components.
    506534  (let ((directory (normalize-pathname-directory-component specified)))
    507535    (ecase (first directory)
     
    525553              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
    526554
    527 (defun* ununspecific (x)
    528   (if (eq x :unspecific) nil x))
     555(defun* make-pathname-component-logical (x)
     556  "Make a pathname component suitable for use in a logical-pathname"
     557  (typecase x
     558    ((eql :unspecific) nil)
     559    #+clisp (string (string-upcase x))
     560    #+clisp (cons (mapcar 'make-pathname-component-logical x))
     561    (t x)))
     562
     563(defun* make-pathname-logical (pathname host)
     564  "Take a PATHNAME's directory, name, type and version components,
     565and make a new pathname with corresponding components and specified logical HOST"
     566  (make-pathname
     567   :host host
     568   :directory (make-pathname-component-logical (pathname-directory pathname))
     569   :name (make-pathname-component-logical (pathname-name pathname))
     570   :type (make-pathname-component-logical (pathname-type pathname))
     571   :version (make-pathname-component-logical (pathname-version pathname))))
    529572
    530573(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     
    547590         (version (or (pathname-version specified) (pathname-version defaults))))
    548591    (labels ((unspecific-handler (p)
    549                (if (typep p 'logical-pathname) #'ununspecific #'identity)))
     592               (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
    550593      (multiple-value-bind (host device directory unspecific-handler)
    551594          (ecase (first directory)
     
    615658         ;; Giving :unspecific as argument to make-pathname is not portable.
    616659         ;; See CLHS make-pathname and 19.2.2.2.3.
    617          ;; We only use it on implementations that support it.
    618          (or #+(or clozure gcl lispworks sbcl) :unspecific)))
     660         ;; We only use it on implementations that support it,
     661         #+(or abcl allegro clozure cmu gcl genera lispworks sbcl scl xcl) :unspecific
     662         #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil))
    619663    (destructuring-bind (name &optional (type unspecific))
    620664        (split-string filename :max 2 :separator ".")
     
    745789  (and (typep pathspec '(or pathname string))
    746790       (eq :absolute (car (pathname-directory (pathname pathspec))))))
     791
     792(defun* coerce-pathname (name &key type defaults)
     793  "coerce NAME into a PATHNAME.
     794When given a string, portably decompose it into a relative pathname:
     795#\\/ separates subdirectories. The last #\\/-separated string is as follows:
     796if TYPE is NIL, its last #\\. if any separates name and type from from type;
     797if TYPE is a string, it is the type, and the whole string is the name;
     798if TYPE is :DIRECTORY, the string is a directory component;
     799if the string is empty, it's a directory.
     800Any directory named .. is read as :BACK.
     801Host, device and version components are taken from DEFAULTS."
     802  ;; The defaults are required notably because they provide the default host
     803  ;; to the below make-pathname, which may crucially matter to people using
     804  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
     805  ;; NOTE that the host and device slots will be taken from the defaults,
     806  ;; but that should only matter if you later merge relative pathnames with
     807  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
     808  (etypecase name
     809    ((or null pathname)
     810     name)
     811    (symbol
     812     (coerce-pathname (string-downcase name) :type type :defaults defaults))
     813    (string
     814     (multiple-value-bind (relative path filename)
     815         (component-name-to-pathname-components name :force-directory (eq type :directory)
     816                                                :force-relative t)
     817       (multiple-value-bind (name type)
     818           (cond
     819             ((or (eq type :directory) (null filename))
     820              (values nil nil))
     821             (type
     822              (values filename type))
     823             (t
     824              (split-name-type filename)))
     825         (apply 'make-pathname :directory (cons relative path) :name name :type type
     826                (when defaults `(:defaults ,defaults))))))))
     827
     828(defun* merge-component-name-type (name &key type defaults)
     829  ;; For backwards compatibility only, for people using internals.
     830  ;; Will be removed in a future release, e.g. 2.016.
     831  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
     832  (coerce-pathname name :type type :defaults defaults))
     833
     834(defun* subpathname (pathname subpath &key type)
     835  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
     836                                  (pathname-directory-pathname pathname))))
     837
     838(defun subpathname* (pathname subpath &key type)
     839  (and pathname
     840       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
    747841
    748842(defun* length=n-p (x n) ;is it that (= (length x) n) ?
     
    897991        (port (ext:pathname-port pathname))
    898992        (directory (pathname-directory pathname)))
    899     (if (or (ununspecific port)
    900             (and (ununspecific host) (plusp (length host)))
    901             (ununspecific scheme))
     993    (flet ((specificp (x) (and x (not (eq x :unspecific)))))
     994      (if (or (specificp port)
     995              (and (specificp host) (plusp (length host)))
     996              (specificp scheme))
    902997        (let ((prefix ""))
    903           (when (ununspecific port)
     998          (when (specificp port)
    904999            (setf prefix (format nil ":~D" port)))
    905           (when (and (ununspecific host) (plusp (length host)))
     1000          (when (and (specificp host) (plusp (length host)))
    9061001            (setf prefix (strcat host prefix)))
    9071002          (setf prefix (strcat ":" prefix))
    908           (when (ununspecific scheme)
     1003          (when (specificp scheme)
    9091004            (setf prefix (strcat scheme prefix)))
    9101005          (assert (and directory (eq (first directory) :absolute)))
    9111006          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
    9121007                         :defaults pathname)))
    913     pathname))
     1008    pathname)))
    9141009
    9151010;;;; -------------------------------------------------------------------------
     
    9491044(defgeneric* (setf component-property) (new-value component property))
    9501045
     1046(defgeneric* component-external-format (component))
     1047
     1048(defgeneric* component-encoding (component))
     1049
    9511050(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
    9521051  (defgeneric* (setf module-components-by-name) (new-value module)))
     
    10261125;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
    10271126(when *upgraded-p*
    1028    (when (find-class 'module nil)
    1029      (eval
    1030       '(defmethod update-instance-for-redefined-class :after
    1031            ((m module) added deleted plist &key)
    1032          (declare (ignorable deleted plist))
    1033          (when *asdf-verbose*
    1034            (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
    1035                          m (asdf-version)))
    1036          (when (member 'components-by-name added)
    1037            (compute-module-components-by-name m))
    1038          (when (typep m 'system)
    1039            (when (member 'source-file added)
    1040              (%set-system-source-file
    1041               (probe-asd (component-name m) (component-pathname m)) m)
    1042              (when (equal (component-name m) "asdf")
    1043                (setf (component-version m) *asdf-version*))))))))
     1127  (when (find-class 'module nil)
     1128    (eval
     1129     '(defmethod update-instance-for-redefined-class :after
     1130          ((m module) added deleted plist &key)
     1131        (declare (ignorable deleted plist))
     1132        (when *asdf-verbose*
     1133          (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
     1134                        m (asdf-version)))
     1135        (when (member 'components-by-name added)
     1136          (compute-module-components-by-name m))
     1137        (when (typep m 'system)
     1138          (when (member 'source-file added)
     1139            (%set-system-source-file
     1140             (probe-asd (component-name m) (component-pathname m)) m)
     1141           (when (equal (component-name m) "asdf")
     1142             (setf (component-version m) *asdf-version*))))))))
    10441143
    10451144;;;; -------------------------------------------------------------------------
     
    11511250   ;; hasn't yet been loaded in the current image (do-first).
    11521251   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
     1252   ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
     1253   ;; Maybe rename the slots in ASDF? But that's not very backwards compatible.
    11531254   ;; See our ASDF 2 paper for more complete explanations.
    11541255   (in-order-to :initform nil :initarg :in-order-to
     
    11691270                    :accessor component-operation-times)
    11701271   (around-compile :initarg :around-compile)
     1272   (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
    11711273   ;; XXX we should provide some atomic interface for updating the
    11721274   ;; component properties
     
    12421344    :accessor module-if-component-dep-fails)
    12431345   (default-component-class
    1244     :initform *default-component-class*
     1346    :initform nil
    12451347    :initarg :default-component-class
    12461348    :accessor module-default-component-class)))
     
    12781380              (acons property new-value (slot-value c 'properties)))))
    12791381  new-value)
     1382
     1383(defvar *default-encoding* :default
     1384  "Default encoding for source files.
     1385The default value :default preserves the legacy behavior.
     1386A future default might be :utf-8 or :autodetect
     1387reading emacs-style -*- coding: utf-8 -*- specifications,
     1388and falling back to utf-8 or latin1 if nothing is specified.")
     1389
     1390(defparameter *utf-8-external-format*
     1391  #+(and asdf-unicode (not clisp)) :utf-8
     1392  #+(and asdf-unicode clisp) charset:utf-8
     1393  #-asdf-unicode :default
     1394  "Default :external-format argument to pass to CL:OPEN and also
     1395CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
     1396On modern implementations, this will decode UTF-8 code points as CL characters.
     1397On legacy implementations, it may fall back on some 8-bit encoding,
     1398with non-ASCII code points being read as several CL characters;
     1399hopefully, if done consistently, that won't affect program behavior too much.")
     1400
     1401(defun* always-default-encoding (pathname)
     1402  (declare (ignore pathname))
     1403  *default-encoding*)
     1404
     1405(defvar *encoding-detection-hook* #'always-default-encoding
     1406  "Hook for an extension to define a function to automatically detect a file's encoding")
     1407
     1408(defun* detect-encoding (pathname)
     1409  (funcall *encoding-detection-hook* pathname))
     1410
     1411(defmethod component-encoding ((c component))
     1412  (or (loop :for x = c :then (component-parent x)
     1413        :while x :thereis (%component-encoding x))
     1414      (detect-encoding (component-pathname c))))
     1415
     1416(defun* default-encoding-external-format (encoding)
     1417  (case encoding
     1418    (:default :default) ;; for backwards compatibility only. Explicit usage discouraged.
     1419    (:utf-8 *utf-8-external-format*)
     1420    (otherwise
     1421     (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
     1422     :default)))
     1423
     1424(defvar *encoding-external-format-hook*
     1425  #'default-encoding-external-format
     1426  "Hook for an extension to define a mapping between non-default encodings
     1427and implementation-defined external-format's")
     1428
     1429(defun encoding-external-format (encoding)
     1430  (funcall *encoding-external-format-hook* encoding))
     1431
     1432(defmethod component-external-format ((c component))
     1433  (encoding-external-format (component-encoding c)))
    12801434
    12811435(defclass proto-system () ; slots to keep when resetting a system
     
    14421596  (gethash (coerce-name name) *defined-systems*))
    14431597
     1598(defun* registered-systems ()
     1599  (loop :for (() . system) :being :the :hash-values :of *defined-systems*
     1600    :collect (coerce-name system)))
     1601
    14441602(defun* register-system (system)
    14451603  (check-type system system)
     
    15321690  (block nil
    15331691    (when (directory-pathname-p defaults)
    1534       (let ((file (make-pathname
    1535                    :defaults defaults :name name
    1536                    :version :newest :case :local :type "asd")))
    1537         (when (probe-file* file)
     1692      (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")))))
     1693        (when file
    15381694          (return file)))
    15391695      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
     
    16511807             (let ((*package* package)
    16521808                   (*default-pathname-defaults*
    1653                     (pathname-directory-pathname pathname)))
     1809                    ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
     1810                    (pathname-directory-pathname (translate-logical-pathname pathname)))
     1811                   (external-format (encoding-external-format (detect-encoding pathname))))
    16541812               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    16551813                             pathname package)
    1656                (load pathname)))
     1814               (load pathname :external-format external-format)))
    16571815        (delete-package package)))))
    16581816
    16591817(defun* locate-system (name)
    16601818  "Given a system NAME designator, try to locate where to load the system from.
    1661 Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
    1662 FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
     1819Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
     1820FOUNDP is true when a system was found,
     1821either a new unregistered one or a previously registered one.
    16631822FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
    1664 PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
     1823PATHNAME when not null is a path from where to load the system,
     1824either associated with FOUND-SYSTEM, or with the PREVIOUS system.
    16651825PREVIOUS when not null is a previously loaded SYSTEM object of same name.
    16661826PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
     
    16701830         (previous (and (typep previous 'system) previous))
    16711831         (previous-time (car in-memory))
    1672            (found (search-for-system-definition name))
     1832         (found (search-for-system-definition name))
    16731833         (found-system (and (typep found 'system) found))
    16741834         (pathname (or (and (typep found '(or pathname string)) (pathname found))
     
    17161876        (reinitialize-source-registry-and-retry ()
    17171877          :report (lambda (s)
    1718                     (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
     1878                    (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
    17191879          (initialize-source-registry))))))
    17201880
     
    17901950  (source-file-explicit-type component))
    17911951
    1792 (defun* coerce-pathname (name &key type defaults)
    1793   "coerce NAME into a PATHNAME.
    1794 When given a string, portably decompose it into a relative pathname:
    1795 #\\/ separates subdirectories. The last #\\/-separated string is as follows:
    1796 if TYPE is NIL, its last #\\. if any separates name and type from from type;
    1797 if TYPE is a string, it is the type, and the whole string is the name;
    1798 if TYPE is :DIRECTORY, the string is a directory component;
    1799 if the string is empty, it's a directory.
    1800 Any directory named .. is read as :BACK.
    1801 Host, device and version components are taken from DEFAULTS."
    1802   ;; The defaults are required notably because they provide the default host
    1803   ;; to the below make-pathname, which may crucially matter to people using
    1804   ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
    1805   ;; NOTE that the host and device slots will be taken from the defaults,
    1806   ;; but that should only matter if you later merge relative pathnames with
    1807   ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
    1808   (etypecase name
    1809     ((or null pathname)
    1810      name)
    1811     (symbol
    1812      (coerce-pathname (string-downcase name) :type type :defaults defaults))
    1813     (string
    1814      (multiple-value-bind (relative path filename)
    1815          (component-name-to-pathname-components name :force-directory (eq type :directory)
    1816                                                 :force-relative t)
    1817        (multiple-value-bind (name type)
    1818            (cond
    1819              ((or (eq type :directory) (null filename))
    1820               (values nil nil))
    1821              (type
    1822               (values filename type))
    1823              (t
    1824               (split-name-type filename)))
    1825          (apply 'make-pathname :directory (cons relative path) :name name :type type
    1826                 (when defaults `(:defaults ,defaults))))))))
    1827 
    1828 (defun* merge-component-name-type (name &key type defaults)
    1829   ;; For backwards compatibility only, for people using internals.
    1830   ;; Will be removed in a future release, e.g. 2.016.
    1831   (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
    1832   (coerce-pathname name :type type :defaults defaults))
    1833 
    18341952(defmethod component-relative-pathname ((component component))
    18351953  (coerce-pathname
     
    18381956   :type (source-file-type component (component-system component))
    18391957   :defaults (component-parent-pathname component)))
    1840 
    1841 (defun* subpathname (pathname subpath &key type)
    1842   (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
    1843                                   (pathname-directory-pathname pathname))))
    1844 
    1845 (defun subpathname* (pathname subpath &key type)
    1846   (and pathname
    1847        (subpathname (ensure-directory-pathname pathname) subpath :type type)))
    18481958
    18491959;;;; -------------------------------------------------------------------------
     
    18621972   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
    18631973   (forced :initform nil :initarg :force :accessor operation-forced)
     1974   (forced-not :initform nil :initarg :force-not :accessor operation-forced-not)
    18641975   (original-initargs :initform nil :initarg :original-initargs
    18651976                      :accessor operation-original-initargs)
     
    18741985
    18751986(defmethod shared-initialize :after ((operation operation) slot-names
    1876                                      &key force
     1987                                     &key force force-not
    18771988                                     &allow-other-keys)
    1878   (declare (ignorable operation slot-names force))
    1879   ;; empty method to disable initarg validity checking
     1989  ;; the &allow-other-keys disables initarg validity checking
     1990  (declare (ignorable operation slot-names force force-not))
     1991  (macrolet ((frob (x) ;; normalize forced and forced-not slots
     1992               `(when (consp (,x operation))
     1993                  (setf (,x operation)
     1994                        (mapcar #'coerce-name (,x operation))))))
     1995    (frob operation-forced) (frob operation-forced-not))
    18801996  (values))
    18811997
     
    20552171      (retry ()
    20562172        :report (lambda (s)
    2057                   (format s "~@<Retry loading ~3i~_~A.~@:>" name))
     2173                  (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
    20582174        :test
    20592175        (lambda (c)
     
    21452261      (setf (visiting-component operation c) t)
    21462262      (unwind-protect
    2147            (progn
    2148              (let ((f (operation-forced
    2149                        (operation-ancestor operation))))
    2150                (when (and f (or (not (consp f)) ;; T or :ALL
    2151                                 (and (typep c 'system) ;; list of names of systems to force
    2152                                      (member (component-name c) f
    2153                                              :test #'string=))))
    2154                  (setf *forcing* t)))
     2263           (block nil
     2264             (when (typep c 'system) ;; systems can be forced or forced-not
     2265               (let ((ancestor (operation-ancestor operation)))
     2266                 (flet ((match? (f)
     2267                          (and f (or (not (consp f)) ;; T or :ALL
     2268                                     (member (component-name c) f :test #'equal)))))
     2269                   (cond
     2270                     ((match? (operation-forced ancestor))
     2271                      (setf *forcing* t))
     2272                     ((match? (operation-forced-not ancestor))
     2273                      (return))))))
    21552274             ;; first we check and do all the dependencies for the module.
    21562275             ;; Operations planned in this loop will show up
     
    22072326                 (do-collect collect (vector module-ops))
    22082327                 (do-collect collect (cons operation c)))))
    2209              (setf (visiting-component operation c) nil)))
    2210       (visit-component operation c (when flag (incf *visit-count*)))
    2211       flag))
     2328        (setf (visiting-component operation c) nil)))
     2329    (visit-component operation c (when flag (incf *visit-count*)))
     2330    flag))
    22122331
    22132332(defun* flatten-tree (l)
     
    22282347
    22292348(defmethod traverse ((operation operation) (c component))
    2230   (when (consp (operation-forced operation))
    2231     (setf (operation-forced operation)
    2232           (mapcar #'coerce-name (operation-forced operation))))
    22332349  (flatten-tree
    22342350   (while-collecting (collect)
     
    23012417
    23022418(defun* ensure-all-directories-exist (pathnames)
    2303    (loop :for pn :in pathnames
    2304      :for pathname = (if (typep pn 'logical-pathname)
    2305                          (translate-logical-pathname pn)
    2306                          pn)
    2307      :do (ensure-directories-exist pathname)))
     2419   (dolist (pathname pathnames)
     2420     (ensure-directories-exist (translate-logical-pathname pathname))))
    23082421
    23092422(defmethod perform :before ((operation compile-op) (c source-file))
    2310   (ensure-all-directories-exist (asdf:output-files operation c)))
     2423  (ensure-all-directories-exist (output-files operation c)))
    23112424
    23122425(defmethod perform :after ((operation operation) (c component))
     
    23542467         c #'(lambda ()
    23552468               (apply *compile-op-compile-file-function* source-file
    2356                       :output-file output-file (compile-op-flags operation))))
     2469                      :output-file output-file
     2470                      :external-format (component-external-format c)
     2471                      (compile-op-flags operation))))
    23572472      (unless output
    23582473        (error 'compile-error :component c :operation operation))
     
    24602575  (let ((source (component-pathname c)))
    24612576    (setf (component-property c 'last-loaded-as-source)
    2462           (and (call-with-around-compile-hook c #'(lambda () (load source)))
     2577          (and (call-with-around-compile-hook
     2578                c #'(lambda () (load source :external-format (component-external-format c))))
    24632579               (get-universal-time)))))
    24642580
     
    25222638;;;; Separating this into a different function makes it more forward-compatible
    25232639(defun* cleanup-upgraded-asdf (old-version)
    2524   (let ((new-version (asdf:asdf-version)))
     2640  (let ((new-version (asdf-version)))
    25252641    (unless (equal old-version new-version)
    25262642      (cond
     
    25482664;;;; We need do that before we operate on anything that depends on ASDF.
    25492665(defun* upgrade-asdf ()
    2550   (let ((version (asdf:asdf-version)))
     2666  (let ((version (asdf-version)))
    25512667    (handler-bind (((or style-warning warning) #'muffle-warning))
    25522668      (operate 'load-op :asdf :verbose nil))
     
    26302746  (map () 'load-system systems))
    26312747
     2748(defun component-loaded-p (c)
     2749  (and (gethash 'load-op (component-operation-times (find-component c nil))) t))
     2750
     2751(defun loaded-systems ()
     2752  (remove-if-not 'component-loaded-p (registered-systems)))
     2753
     2754(defun require-system (s)
     2755  (load-system s :force-not (loaded-systems)))
     2756
    26322757(defun* compile-system (system &rest args &key force verbose version
    26332758                       &allow-other-keys)
    2634   "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
     2759  "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE
    26352760for details."
    26362761  (declare (ignore force verbose version))
     
    26402765(defun* test-system (system &rest args &key force verbose version
    26412766                    &allow-other-keys)
    2642   "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
     2767  "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for
    26432768details."
    26442769  (declare (ignore force verbose version))
     
    26642789        (default-directory))))
    26652790
     2791(defun* find-class* (x &optional (errorp t) environment)
     2792  (etypecase x
     2793    ((or standard-class built-in-class) x)
     2794    (symbol (find-class x errorp environment))))
     2795
    26662796(defun* class-for-type (parent type)
    26672797  (or (loop :for symbol :in (list
     
    26752805        :return class)
    26762806      (and (eq type :file)
    2677            (or (and parent (module-default-component-class parent))
    2678                (find-class *default-component-class*)))
     2807           (find-class*
     2808            (or (loop :for module = parent :then (component-parent module) :while module
     2809                  :thereis (module-default-component-class module))
     2810                *default-component-class*) nil))
    26792811      (sysdef-error "don't recognize component type ~A" type)))
    26802812
     
    27622894              ;; the following list of keywords is reproduced below in the
    27632895              ;; remove-keys form.  important to keep them in sync
    2764               components pathname default-component-class
     2896              components pathname
    27652897              perform explain output-files operation-done-p
    2766               weakly-depends-on
    2767               depends-on serial in-order-to do-first
     2898              weakly-depends-on depends-on serial in-order-to
     2899              do-first
    27682900              (version nil versionp)
    27692901              ;; list ends
     
    27892921                        :parent parent
    27902922                        (remove-keys
    2791                          '(components pathname default-component-class
     2923                         '(components pathname
    27922924                           perform explain output-files operation-done-p
    27932925                           weakly-depends-on depends-on serial in-order-to)
     
    28032935      (component-pathname ret) ; eagerly compute the absolute pathname
    28042936      (when (typep ret 'module)
    2805         (setf (module-default-component-class ret)
    2806               (or default-component-class
    2807                   (and (typep parent 'module)
    2808                        (module-default-component-class parent))))
    28092937        (let ((*serial-depends-on* nil))
    28102938          (setf (module-components ret)
     
    28943022;;;; As a suggested replacement which is portable to all ASDF-supported
    28953023;;;; implementations and operating systems except Genera, I recommend
    2896 ;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its
    2897 ;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
     3024;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives.
    28983025
    28993026(defun* run-shell-command (control-string &rest args)
     
    30193146
    30203147(defmethod system-source-file ((system system))
     3148  ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed
     3149  (unless (slot-boundp system 'source-file)
     3150    (%set-system-source-file
     3151     (probe-asd (component-name system) (component-pathname system)) system))
    30213152  (%system-source-file system))
    30223153(defmethod system-source-file ((system-name string))
     
    30903221(defun* ccl-fasl-version ()
    30913222  ;; the fasl version is target-dependent from CCL 1.8 on.
    3092   (or (and (fboundp 'ccl::target-fasl-version)
    3093            (funcall 'ccl::target-fasl-version))
     3223  (or (let ((s 'ccl::target-fasl-version))
     3224        (and (fboundp s) (funcall s)))
    30943225      (and (boundp 'ccl::fasl-version)
    30953226           (symbol-value 'ccl::fasl-version))
     
    31393270           (or (architecture) (machine-type)))))
    31403271
     3272(defun* hostname ()
     3273  ;; Note: untested on RMCL
     3274  #+(or abcl clozure cmucl ecl genera lispworks mcl sbcl scl xcl) (machine-instance)
     3275  #+cormanlisp "localhost" ;; is there a better way? Does it matter?
     3276  #+allegro (excl.osi:gethostname)
     3277  #+clisp (first (split-string (machine-instance) :separator " "))
     3278  #+gcl (system:gethostname))
     3279
    31413280
    31423281;;; ---------------------------------------------------------------------------
     
    31663305  (ensure-absolute-pathname* s "from (getenv ~S)" x))
    31673306(defun getenv-absolute-pathnames (x &aux (s (getenv x)))
    3168   (split-absolute-pathnames s "from (getenv ~S) = ~S" x s))
     3307  (and (plusp (length s))
     3308       (split-absolute-pathnames s "from (getenv ~S) = ~S" x s)))
    31693309
    31703310(defun* user-configuration-directories ()
     
    33793519              (coerce-pathname (implementation-identifier) :type :directory))
    33803520             ((eql :implementation-type)
    3381               (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
     3521              (coerce-pathname (string-downcase (implementation-type)) :type :directory))
     3522             ((eql :hostname)
     3523              (coerce-pathname (hostname) :type :directory)))))
    33823524    (when (absolute-pathname-p r)
    33833525      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
     
    35493691                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
    35503692    ;; The below two are not needed: no precompiled ASDF system there
    3551     ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
     3693    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
    35523694    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
    35533695    ;; All-import, here is where we want user stuff to be:
     
    38654007        :for p = (or (and (typep f 'logical-pathname) f)
    38664008                     (let* ((u (ignore-errors (funcall merger f))))
    3867                        ;; The first u avoids a cumbersome (truename u) error
    3868                        (and u (equal (ignore-errors (truename u)) f) u)))
     4009                       ;; The first u avoids a cumbersome (truename u) error.
     4010                       ;; At this point f should already be a truename,
     4011                       ;; but isn't quite in CLISP, for doesn't have :version :newest
     4012                       (and u (equal (ignore-errors (truename u)) (truename f)) u)))
    38694013        :when p :collect p)
    38704014      entries))
    38714015
    38724016(defun* directory-files (directory &optional (pattern *wild-file*))
    3873   (when (wild-pathname-p directory)
    3874     (error "Invalid wild in ~S" directory))
    3875   (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
    3876     (error "Invalid file pattern ~S" pattern))
    3877   (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
    3878     (filter-logical-directory-results
    3879      directory entries
    3880      #'(lambda (f)
    3881          (make-pathname :defaults directory
    3882                         :name (pathname-name f) :type (ununspecific (pathname-type f))
    3883                         :version (ununspecific (pathname-version f)))))))
     4017  (let ((dir (pathname directory)))
     4018    (when (typep dir 'logical-pathname)
     4019      ;; Because of the filtering we do below,
     4020      ;; logical pathnames have restrictions on wild patterns.
     4021      ;; Not that the results are very portable when you use these patterns on physical pathnames.
     4022      (when (wild-pathname-p dir)
     4023        (error "Invalid wild pattern in logical directory ~S" directory))
     4024      (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
     4025        (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
     4026      (setf pattern (make-pathname-logical pattern (pathname-host dir))))
     4027    (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
     4028      (filter-logical-directory-results
     4029       directory entries
     4030       #'(lambda (f)
     4031           (make-pathname :defaults dir
     4032                          :name (make-pathname-component-logical (pathname-name f))
     4033                          :type (make-pathname-component-logical (pathname-type f))
     4034                          :version (make-pathname-component-logical (pathname-version f))))))))
    38844035
    38854036(defun* directory-asd-files (directory)
     
    39144065    (filter-logical-directory-results
    39154066     directory dirs
    3916      (let ((prefix (normalize-pathname-directory-component
    3917                     (pathname-directory directory))))
     4067     (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
     4068                       '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
    39184069       #'(lambda (d)
    3919            (let ((dir (normalize-pathname-directory-component
    3920                        (pathname-directory d))))
     4070           (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
    39214071             (and (consp dir) (consp (cdr dir))
    39224072                  (make-pathname
    39234073                   :defaults directory :name nil :type nil :version nil
    3924                    :directory (append prefix (last dir))))))))))
     4074                   :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
    39254075
    39264076(defun* collect-asds-in-directory (directory collect)
     
    42564406          (system (find-system (string-downcase name) nil)))
    42574407      (when system
    4258         (operate *require-asdf-operator* system :verbose nil)
     4408        (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems))
    42594409        t))))
    42604410
Note: See TracChangeset for help on using the changeset viewer.