Changeset 13311 for trunk/abcl/src/org


Ignore:
Timestamp:
06/08/11 05:23:25 (10 years ago)
Author:
Mark Evenson
Message:

Update to asdf-2.016.

File:
1 edited

Legend:

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

    r13258 r13311  
    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.016: 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  (defun find-symbol* (s p)
     83    (find-symbol (string s) p))
     84  ;; Strip out formatting that is not supported on Genera.
     85  ;; Has to be inside the eval-when to make Lispworks happy (!)
     86  (defmacro compatfmt (format)
     87    #-genera format
     88    #+genera
     89    (loop :for (unsupported . replacement) :in
     90      '(("~@<" . "")
     91        ("; ~@;" . "; ")
     92        ("~3i~_" . "")
     93        ("~@:>" . "")
     94        ("~:>" . "")) :do
     95      (loop :for found = (search unsupported format) :while found :do
     96        (setf format
     97              (concatenate 'simple-string
     98                           (subseq format 0 found) replacement
     99                           (subseq format (+ found (length unsupported)))))))
     100    format)
    94101  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
    95102         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
     
    100107         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    101108         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    102          (asdf-version "2.014")
    103          (existing-asdf (fboundp 'find-system))
     109         (asdf-version "2.016")
     110         (existing-asdf (find-class 'component nil))
    104111         (existing-version *asdf-version*)
    105112         (already-there (equal asdf-version existing-version)))
    106113    (unless (and existing-asdf already-there)
    107       (when existing-asdf
     114      (when (and existing-asdf *asdf-verbose*)
    108115        (format *trace-output*
    109     (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
    110     existing-version asdf-version))
     116                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
     117                existing-version asdf-version))
    111118      (labels
    112119          ((present-symbol-p (symbol package)
    113              (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
     120             (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
    114121           (present-symbols (package)
    115122             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
     
    141148                   (t
    142149                    (make-package name :nicknames nicknames :use use))))))
    143            (find-sym (symbol package)
    144              (find-symbol (string symbol) package))
    145150           (intern* (symbol package)
    146151             (intern (string symbol) package))
    147152           (remove-symbol (symbol package)
    148              (let ((sym (find-sym symbol package)))
     153             (let ((sym (find-symbol* symbol package)))
    149154               (when sym
    150                  (unexport sym package)
     155                 #-cormanlisp (unexport sym package)
    151156                 (unintern sym package)
    152157                 sym)))
     
    157162               :when removed :do
    158163               (loop :for p :in packages :do
    159                  (when (eq removed (find-sym sym p))
     164                 (when (eq removed (find-symbol* sym p))
    160165                   (unintern removed p)))))
    161166           (ensure-shadow (package symbols)
     
    164169             (dolist (used (reverse use))
    165170               (do-external-symbols (sym used)
    166                  (unless (eq sym (find-sym sym package))
     171                 (unless (eq sym (find-symbol* sym package))
    167172                   (remove-symbol sym package)))
    168173               (use-package used package)))
    169174           (ensure-fmakunbound (package symbols)
    170175             (loop :for name :in symbols
    171                :for sym = (find-sym name package)
     176               :for sym = (find-symbol* name package)
    172177               :when sym :do (fmakunbound sym)))
    173178           (ensure-export (package export)
     
    185190                 :for shadowing = (package-shadowing-symbols user) :do
    186191                 (loop :for new :in newly-exported-symbols
    187                    :for old = (find-sym new user)
     192                   :for old = (find-symbol* new user)
    188193                   :when (and old (not (member old shadowing)))
    189194                   :do (unintern old user)))
     
    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 #:with-system-definitions
     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)
     
    513556  (when pathname
    514557    (make-pathname :name nil :type nil :version nil
    515                    :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
     558                   :directory (merge-pathname-directory-components
     559                               '(:relative :back) (pathname-directory pathname))
    516560                   :defaults pathname)))
    517561
     
    529573  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    530574
    531    
     575
    532576(defun* asdf-message (format-string &rest format-args)
    533577  (declare (dynamic-extent format-args))
    534   (apply #'format *verbose-out* format-string format-args))
     578  (apply 'format *verbose-out* format-string format-args))
    535579
    536580(defun* split-string (string &key max (separator '(#\Space #\Tab)))
     
    540584starting the separation from the end, e.g. when called with arguments
    541585 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
    542   (block nil
     586  (catch nil
    543587    (let ((list nil) (words 0) (end (length string)))
    544588      (flet ((separatorp (char) (find char separator))
    545              (done () (return (cons (subseq string 0 end) list))))
     589             (done () (throw nil (cons (subseq string 0 end) list))))
    546590        (loop
    547591          :for start = (if (and max (>= words (1- max)))
     
    623667(defun* getenv (x)
    624668  (declare (ignorable x))
    625   #+(or abcl clisp) (ext:getenv x)
     669  #+(or abcl clisp xcl) (ext:getenv x)
    626670  #+allegro (sys:getenv x)
    627671  #+clozure (ccl:getenv x)
    628672  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
     673  #+cormanlisp
     674  (let* ((buffer (ct:malloc 1))
     675         (cname (ct:lisp-string-to-c-string x))
     676         (needed-size (win:getenvironmentvariable cname buffer 0))
     677         (buffer1 (ct:malloc (1+ needed-size))))
     678    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
     679               nil
     680               (ct:c-string-to-lisp-string buffer1))
     681      (ct:free buffer)
     682      (ct:free buffer1)))
    629683  #+ecl (si:getenv x)
    630684  #+gcl (system:getenv x)
     
    636690              (ccl:%get-cstring value))))
    637691  #+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"))
     692  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
     693  (error "~S is not supported on your implementation" 'getenv))
    640694
    641695(defun* directory-pathname-p (pathname)
     
    713767  (defun* get-uid ()
    714768    #+allegro (excl.osi:getuid)
     769    #+ccl (ccl::getuid)
    715770    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
    716771                  :for f = (ignore-errors (read-from-string s))
     
    721776                   '(ext::getuid))
    722777    #+sbcl (sb-unix:unix-getuid)
    723     #-(or allegro clisp cmu ecl sbcl scl)
     778    #-(or allegro ccl clisp cmu ecl sbcl scl)
    724779    (let ((uid-string
    725780           (with-output-to-string (*verbose-out*)
     
    733788  (make-pathname :directory '(:absolute)
    734789                 :name nil :type nil :version nil
    735                  :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
     790                 :defaults pathname ;; host device, and on scl, *some*
     791                 ;; scheme-specific parts: port username password, not others:
    736792                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    737 
    738 (defun* find-symbol* (s p)
    739   (find-symbol (string s) p))
    740793
    741794(defun* probe-file* (p)
     
    743796with given pathname and if it exists return its truename."
    744797  (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)))))))
     798    (null nil)
     799    (string (probe-file* (parse-namestring p)))
     800    (pathname (unless (wild-pathname-p p)
     801                #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
     802                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
     803                                   `(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*
     868                 :version (or #-(or abcl xcl) *wild*) :directory nil))
    799869(defparameter *wild-directory*
    800   (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
     870  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
    801871(defparameter *wild-inferiors*
    802872  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
     
    835905(defun* directorize-pathname-host-device (pathname)
    836906  (let ((scheme (ext:pathname-scheme pathname))
    837   (host (pathname-host pathname))
    838   (port (ext:pathname-port pathname))
    839   (directory (pathname-directory pathname)))
     907        (host (pathname-host pathname))
     908        (port (ext:pathname-port pathname))
     909        (directory (pathname-directory pathname)))
    840910    (flet ((not-unspecific (component)
    841        (and (not (eq component :unspecific)) component)))
     911             (and (not (eq component :unspecific)) component)))
    842912      (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)))))
     913                (and (not-unspecific host) (plusp (length host)))
     914                (not-unspecific scheme))
     915             (let ((prefix ""))
     916               (when (not-unspecific port)
     917                (setf prefix (format nil ":~D" port)))
     918               (when (and (not-unspecific host) (plusp (length host)))
     919                (setf prefix (concatenate 'string host prefix)))
     920               (setf prefix (concatenate 'string ":" prefix))
     921               (when (not-unspecific scheme)
     922               (setf prefix (concatenate 'string scheme prefix)))
     923               (assert (and directory (eq (first directory) :absolute)))
     924               (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
     925                              :defaults pathname)))
     926            (t
     927             pathname)))))
    858928
    859929;;;; -------------------------------------------------------------------------
     
    892962(defgeneric* (setf component-property) (new-value component property))
    893963
     964(eval-when (:compile-toplevel :load-toplevel :execute)
     965  (defgeneric* (setf module-components-by-name) (new-value module)))
     966
    894967(defgeneric* version-satisfies (component version))
    895968
     
    9681041   (when (find-class 'module nil)
    9691042     (eval
    970       `(defmethod update-instance-for-redefined-class :after
     1043      '(defmethod update-instance-for-redefined-class :after
    9711044           ((m module) added deleted plist &key)
    9721045         (declare (ignorable deleted plist))
    973          (when (or *asdf-verbose* *load-verbose*)
     1046         (when *asdf-verbose*
    9741047           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
    975        m ,(asdf-version)))
     1048                         m (asdf-version)))
    9761049         (when (member 'components-by-name added)
    9771050           (compute-module-components-by-name m))
     
    9951068  #+cmu (:report print-object))
    9961069
    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 
    10101070(define-condition formatted-system-definition-error (system-definition-error)
    10111071  ((format-control :initarg :format-control :reader format-control)
    10121072   (format-arguments :initarg :format-arguments :reader format-arguments))
    10131073  (:report (lambda (c s)
    1014                (apply #'format s (format-control c) (format-arguments c)))))
     1074               (apply 'format s (format-control c) (format-arguments c)))))
    10151075
    10161076(define-condition load-system-definition-error (system-definition-error)
     
    10191079   (condition :initarg :condition :reader error-condition))
    10201080  (: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)))))
     1081             (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
     1082                     (error-name c) (error-pathname c) (error-condition c)))))
    10231083
    10241084(define-condition circular-dependency (system-definition-error)
    10251085  ((components :initarg :components :reader circular-dependency-components))
    10261086  (:report (lambda (c s)
    1027        (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
    1028          (circular-dependency-components c)))))
     1087             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
     1088                     (circular-dependency-components c)))))
    10291089
    10301090(define-condition duplicate-names (system-definition-error)
    10311091  ((name :initarg :name :reader duplicate-names-name))
    10321092  (:report (lambda (c s)
    1033        (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
    1034          (duplicate-names-name c)))))
     1093             (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
     1094                     (duplicate-names-name c)))))
    10351095
    10361096(define-condition missing-component (system-definition-error)
     
    10741134
    10751135(defclass component ()
    1076   ((name :accessor component-name :initarg :name :documentation
     1136  ((name :accessor component-name :initarg :name :type string :documentation
    10771137         "Component name: designator for a string composed of portable pathname characters")
     1138   ;; We might want to constrain version with
     1139   ;; :type (and string (satisfies parse-version))
     1140   ;; but we cannot until we fix all systems that don't use it correctly!
    10781141   (version :accessor component-version :initarg :version)
    10791142   (description :accessor component-description :initarg :description)
     
    11551218          (missing-version c)
    11561219          (when (missing-parent c)
    1157             (component-name (missing-parent c)))))
     1220            (coerce-name (missing-parent c)))))
    11581221
    11591222(defmethod component-system ((component component))
     
    12451308(defmethod version-satisfies ((c component) version)
    12461309  (unless (and version (slot-boundp c 'version))
     1310    (when version
     1311      (warn "Requested version ~S but component ~S has no version" version c))
    12471312    (return-from version-satisfies t))
    12481313  (version-satisfies (component-version c) version))
    12491314
     1315(defun parse-version (string &optional on-error)
     1316  "Parse a version string as a series of natural integers separated by dots.
     1317Return a (non-null) list of integers if the string is valid, NIL otherwise.
     1318If on-error is error, warn, or designates a function of compatible signature,
     1319the function is called with an explanation of what is wrong with the argument.
     1320NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
     1321  (and
     1322   (or (stringp string)
     1323       (when on-error
     1324         (funcall on-error "~S: ~S is not a string"
     1325                  'parse-version string)) nil)
     1326   (or (loop :for prev = nil :then c :for c :across string
     1327         :always (or (digit-char-p c)
     1328                     (and (eql c #\.) prev (not (eql prev #\.))))
     1329         :finally (return (and c (digit-char-p c))))
     1330       (when on-error
     1331         (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
     1332                  'parse-version string)) nil)
     1333   (mapcar #'parse-integer (split-string string :separator "."))))
     1334
    12501335(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 "."))))
     1336  (let ((x (parse-version cver 'warn))
     1337        (y (parse-version version 'warn)))
    12551338    (labels ((bigger (x y)
    12561339               (cond ((not y) t)
     
    12591342                     ((= (car x) (car y))
    12601343                      (bigger (cdr x) (cdr y))))))
    1261       (and (= (car x) (car y))
     1344      (and x y (= (car x) (car y))
    12621345           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    12631346
     
    12851368  (gethash (coerce-name name) *defined-systems*))
    12861369
     1370(defun* register-system (system)
     1371  (check-type system system)
     1372  (let ((name (component-name system)))
     1373    (check-type name string)
     1374    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
     1375    (unless (eq system (cdr (gethash name *defined-systems*)))
     1376      (setf (gethash name *defined-systems*)
     1377            (cons (get-universal-time) system)))))
     1378
    12871379(defun* clear-system (name)
    12881380  "Clear the entry for a system in the database of systems previously loaded.
    12891381Note 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.
     1382  ;; There is no "unload" operation in Common Lisp, and
     1383  ;; a general such operation cannot be portably written,
     1384  ;; considering how much CL relies on side-effects to global data structures.
    12931385  (remhash (coerce-name name) *defined-systems*))
    12941386
     
    13091401
    13101402(defparameter *system-definition-search-functions*
    1311   '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    1312 
    1313 (defun* system-definition-pathname (system)
     1403  '(sysdef-central-registry-search
     1404    sysdef-source-registry-search
     1405    sysdef-find-asdf))
     1406
     1407(defun* search-for-system-definition (system)
    13141408  (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)))))))
     1409    (some #'(lambda (x) (funcall x system-name))
     1410          (cons 'find-system-if-being-defined *system-definition-search-functions*))))
    13211411
    13221412(defvar *central-registry* nil
     
    13821472                          (coerce-entry-to-directory ()
    13831473                            :report (lambda (s)
    1384               (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
    1385                 (ensure-directory-pathname defaults) dir))
     1474                                      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
     1475                                              (ensure-directory-pathname defaults) dir))
    13861476                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    13871477        ;; cleanup
     
    14151505  ;; as if the file were very old.
    14161506  ;; (or should we treat the case in a different, special way?)
    1417   (or (and pathname (probe-file* pathname) (file-write-date pathname))
     1507  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
    14181508      (progn
    14191509        (when (and pathname *asdf-verbose*)
     
    14221512        0)))
    14231513
     1514(defmethod find-system ((name null) &optional (error-p t))
     1515  (when error-p
     1516    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
     1517
    14241518(defmethod find-system (name &optional (error-p t))
    14251519  (find-system (coerce-name name) error-p))
    14261520
    1427 (defun load-sysdef (name pathname)
     1521(defvar *systems-being-defined* nil
     1522  "A hash-table of systems currently being defined keyed by name, or NIL")
     1523
     1524(defun* find-system-if-being-defined (name)
     1525  (when *systems-being-defined*
     1526    (gethash (coerce-name name) *systems-being-defined*)))
     1527
     1528(defun* call-with-system-definitions (thunk)
     1529  (if *systems-being-defined*
     1530      (funcall thunk)
     1531      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
     1532        (funcall thunk))))
     1533
     1534(defmacro with-system-definitions (() &body body)
     1535  `(call-with-system-definitions #'(lambda () ,@body)))
     1536
     1537(defun* load-sysdef (name pathname)
    14281538  ;; Tries to load system definition with canonical NAME from PATHNAME.
    1429   (let ((package (make-temporary-package)))
    1430     (unwind-protect
    1431          (handler-bind
    1432              ((error #'(lambda (condition)
    1433                          (error 'load-system-definition-error
    1434                                 :name name :pathname pathname
    1435                                 :condition condition))))
    1436            (let ((*package* package))
    1437              (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    1438          pathname package)
    1439              (load pathname)))
    1440       (delete-package package))))
     1539  (with-system-definitions ()
     1540    (let ((package (make-temporary-package)))
     1541      (unwind-protect
     1542           (handler-bind
     1543               ((error #'(lambda (condition)
     1544                           (error 'load-system-definition-error
     1545                                  :name name :pathname pathname
     1546                                  :condition condition))))
     1547             (let ((*package* package))
     1548               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
     1549                             pathname package)
     1550               (load pathname)))
     1551        (delete-package package)))))
    14411552
    14421553(defmethod find-system ((name string) &optional (error-p t))
    1443   (catch 'find-system
     1554  (with-system-definitions ()
    14441555    (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)
     1556           (previous (cdr in-memory))
     1557           (previous (and (typep previous 'system) previous))
     1558           (previous-time (car in-memory))
     1559           (found (search-for-system-definition name))
     1560           (found-system (and (typep found 'system) found))
     1561           (pathname (or (and (typep found '(or pathname string)) (pathname found))
     1562                         (and found-system (system-source-file found-system))
     1563                         (and previous (system-source-file previous)))))
     1564      (setf pathname (resolve-symlinks* pathname))
     1565      (when (and pathname (not (absolute-pathname-p pathname)))
     1566        (setf pathname (ensure-pathname-absolute pathname))
     1567        (when found-system
     1568          (%set-system-source-file pathname found-system)))
     1569      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
     1570                                             (system-source-file previous) pathname)))
     1571        (%set-system-source-file pathname previous)
     1572        (setf previous-time nil))
     1573      (when (and found-system (not previous))
     1574        (register-system found-system))
     1575      (when (and pathname
     1576                 (or (not previous-time)
    14481577                     ;; don't reload if it's already been loaded,
    14491578                     ;; or its filestamp is in the future which means some clock is skewed
    14501579                     ;; 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))
     1580                     (< previous-time (safe-file-write-date pathname) (get-universal-time))))
     1581        (load-sysdef name pathname))
    14531582      (let ((in-memory (system-registered-p name))) ; try again after loading from disk
    14541583        (cond
    14551584          (in-memory
    1456            (when on-disk
    1457              (setf (car in-memory) (safe-file-write-date on-disk)))
     1585           (when pathname
     1586             (setf (car in-memory) (safe-file-write-date pathname)))
    14581587           (cdr in-memory))
    14591588          (error-p
    14601589           (error 'missing-component :requires name)))))))
    14611590
    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)))
    1467 
    14681591(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    14691592  (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*)))
    14741593        requested (coerce-name requested))
    14751594  (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))))
     1595    (let ((registered (cdr (gethash fallback *defined-systems*))))
     1596      (or registered
     1597          (apply 'make-instance 'system
     1598                 :name fallback :source-file source-file keys)))))
    14831599
    14841600(defun* sysdef-find-asdf (name)
     
    15241640(defclass cl-source-file (source-file)
    15251641  ((type :initform "lisp")))
     1642(defclass cl-source-file.cl (cl-source-file)
     1643  ((type :initform "cl")))
     1644(defclass cl-source-file.lsp (cl-source-file)
     1645  ((type :initform "lsp")))
    15261646(defclass c-source-file (source-file)
    15271647  ((type :initform "c")))
     
    15731693             (t
    15741694              (split-name-type filename)))
    1575          (make-pathname :directory `(,relative ,@path) :name name :type type
    1576                         :defaults (or defaults *default-pathname-defaults*)))))))
     1695         (apply 'make-pathname :directory (cons relative path) :name name :type type
     1696                (when defaults `(:defaults ,defaults))))))))
    15771697
    15781698(defun* merge-component-name-type (name &key type defaults)
    15791699  ;; For backwards compatibility only, for people using internals.
    1580   ;; Will be removed in a future release, e.g. 2.014.
     1700  ;; Will be removed in a future release, e.g. 2.016.
     1701  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
    15811702  (coerce-pathname name :type type :defaults defaults))
    15821703
     
    15941715
    15951716(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,
     1717  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
     1718   ;; T to force the inside of the specified system,
    15991719   ;;   but not recurse to other systems we depend on.
    16001720   ;; :ALL (or any other atom) to force all systems
     
    16021722   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    16031723   ;;   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.
     1724   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
    16051725   (forced :initform nil :initarg :force :accessor operation-forced)
    16061726   (original-initargs :initform nil :initarg :original-initargs
     
    16441764           (when (eql force-p t)
    16451765             (setf (getf args :force) nil))
    1646            (apply #'make-instance dep-o
     1766           (apply 'make-instance dep-o
    16471767                  :parent o
    16481768                  :original-initargs args args))
     
    16501770           o)
    16511771          (t
    1652            (apply #'make-instance dep-o
     1772           (apply 'make-instance dep-o
    16531773                  :parent o :original-initargs args args)))))
    16541774
     
    16821802
    16831803(defmethod component-depends-on ((op-spec symbol) (c component))
     1804  ;; Note: we go from op-spec to operation via make-instance
     1805  ;; to allow for specialization through defmethod's, even though
     1806  ;; it's a detour in the default case below.
    16841807  (component-depends-on (make-instance op-spec) c))
    16851808
    16861809(defmethod component-depends-on ((o operation) (c component))
    1687   (cdr (assoc (class-name (class-of o))
    1688               (component-in-order-to c))))
     1810  (cdr (assoc (type-of o) (component-in-order-to c))))
    16891811
    16901812(defmethod component-self-dependencies ((o operation) (c component))
     
    18031925      (retry ()
    18041926        :report (lambda (s)
    1805       (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c))
     1927                  (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
    18061928        :test
    18071929        (lambda (c)
    1808     (or (null c)
    1809         (and (typep c 'missing-dependency)
    1810        (equalp (missing-requires c)
    1811          required-c))))))))
     1930          (or (null c)
     1931              (and (typep c 'missing-dependency)
     1932                   (equalp (missing-requires c)
     1933                           required-c))))))))
    18121934
    18131935(defun* do-dep (operation c collect op dep)
     
    18561978
    18571979(defmethod do-traverse ((operation operation) (c component) collect)
    1858   (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
     1980  (let ((*forcing* *forcing*)
     1981        (flag nil)) ;; return value: must we rebuild this and its dependencies?
    18591982    (labels
    18601983        ((update-flag (x)
    1861            (when x
    1862              (setf flag t)))
     1984           (orf flag x))
    18631985         (dep (op comp)
    18641986           (update-flag (do-dep operation c collect op comp))))
     
    18741996      (unwind-protect
    18751997           (progn
     1998             (let ((f (operation-forced
     1999                       (operation-ancestor operation))))
     2000               (when (and f (or (not (consp f)) ;; T or :ALL
     2001                                (and (typep c 'system) ;; list of names of systems to force
     2002                                     (member (component-name c) f
     2003                                             :test #'string=))))
     2004                 (setf *forcing* t)))
    18762005             ;; first we check and do all the dependencies for the module.
    18772006             ;; Operations planned in this loop will show up
     
    19132042                                     (not at-least-one))
    19142043                            (error error)))))))
    1915                (update-flag
    1916                 (or
    1917                  *forcing*
    1918                  (not (operation-done-p operation c))
     2044               (update-flag (or *forcing* (not (operation-done-p operation c))))
    19192045                 ;; For sub-operations, check whether
    19202046                 ;; the original ancestor operation was forced,
     
    19232049                 ;; between all the things with a given name. Sigh.
    19242050                 ;; 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=)))))))
    19312051               (when flag
    19322052                 (let ((do-first (cdr (assoc (class-name (class-of operation))
     
    19572077
    19582078(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.
    19622079  (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.")
    19652080    (setf (operation-forced operation)
    19662081          (mapcar #'coerce-name (operation-forced operation))))
     
    19802095
    19812096(defmethod explain ((operation operation) (component component))
    1982   (asdf-message "~&;;; ~A~%" (operation-description operation component)))
     2097  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
     2098                (operation-description operation component)))
    19832099
    19842100(defmethod operation-description (operation component)
    1985   (format nil (compatfmt "~@<~A on component ~S~@:>")
    1986     (class-of operation) (component-find-path component)))
     2101  (format nil (compatfmt "~@<~A on ~A~@:>")
     2102          (class-of operation) component))
    19872103
    19882104;;;; -------------------------------------------------------------------------
     
    20312147        (apply *compile-op-compile-file-function* source-file :output-file output-file
    20322148               (compile-op-flags operation))
    2033       (when warnings-p
    2034         (case (operation-on-warnings operation)
    2035           (:warn (warn
    2036                   (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
    2037                   operation c))
    2038           (:error (error 'compile-warned :component c :operation operation))
    2039           (:ignore nil)))
     2149      (unless output
     2150        (error 'compile-error :component c :operation operation))
    20402151      (when failure-p
    20412152        (case (operation-on-failure operation)
     
    20452156          (:error (error 'compile-failed :component c :operation operation))
    20462157          (:ignore nil)))
    2047       (unless output
    2048         (error 'compile-error :component c :operation operation)))))
     2158      (when warnings-p
     2159        (case (operation-on-warnings operation)
     2160          (:warn (warn
     2161                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
     2162                  operation c))
     2163          (:error (error 'compile-warned :component c :operation operation))
     2164          (:ignore nil))))))
    20492165
    20502166(defmethod output-files ((operation compile-op) (c cl-source-file))
     
    20682184(defmethod operation-description ((operation compile-op) component)
    20692185  (declare (ignorable operation))
    2070   (format nil "compiling component ~S" (component-find-path component)))
     2186  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
     2187
     2188(defmethod operation-description ((operation compile-op) (component module))
     2189  (declare (ignorable operation))
     2190  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
     2191
    20712192
    20722193;;;; -------------------------------------------------------------------------
     
    20812202
    20822203(defmethod perform-with-restarts (operation component)
     2204  ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
    20832205  (perform operation component))
    20842206
     
    20952217      (:failed-load
    20962218       (setf state :recompiled)
    2097        (perform (make-instance 'compile-op) c))
     2219       (perform (make-sub-operation c o c 'compile-op) c))
    20982220      (t
    20992221       (with-simple-restart
     
    21432265(defmethod operation-description ((operation load-op) component)
    21442266  (declare (ignorable operation))
    2145   (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
    2146     (component-find-path component)))
    2147 
     2267  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
     2268          component))
     2269
     2270(defmethod operation-description ((operation load-op) (component cl-source-file))
     2271  (declare (ignorable operation))
     2272  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
     2273          component))
     2274
     2275(defmethod operation-description ((operation load-op) (component module))
     2276  (declare (ignorable operation))
     2277  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
     2278          component))
    21482279
    21492280;;;; -------------------------------------------------------------------------
     
    21672298  nil)
    21682299
    2169 ;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
     2300;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
    21702301(defmethod component-depends-on ((o load-source-op) (c component))
    21712302  (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)))
     2303  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
     2304    :for (op . co) :in what-would-load-op-do
     2305    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
    21792306
    21802307(defmethod operation-done-p ((o load-source-op) (c source-file))
     
    21872314(defmethod operation-description ((operation load-source-op) component)
    21882315  (declare (ignorable operation))
    2189   (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
    2190     (component-find-path component)))
     2316  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
     2317          component))
     2318
     2319(defmethod operation-description ((operation load-source-op) (component module))
     2320  (declare (ignorable operation))
     2321  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
    21912322
    21922323
     
    22142345
    22152346(defgeneric* operate (operation-class system &key &allow-other-keys))
     2347(defgeneric* perform-plan (plan &key))
     2348
     2349;;;; Try to upgrade of ASDF. If a different version was used, return T.
     2350;;;; We need do that before we operate on anything that depends on ASDF.
     2351(defun* upgrade-asdf ()
     2352  (let ((version (asdf:asdf-version)))
     2353    (handler-bind (((or style-warning warning) #'muffle-warning))
     2354      (operate 'load-op :asdf :verbose nil))
     2355    (let ((new-version (asdf:asdf-version)))
     2356      (block nil
     2357        (cond
     2358          ((equal version new-version)
     2359           (return nil))
     2360          ((version-satisfies new-version version)
     2361           (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
     2362                         version new-version))
     2363          ((version-satisfies version new-version)
     2364           (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
     2365                 version new-version))
     2366          (t
     2367           (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
     2368                         version new-version)))
     2369        (let ((asdf (find-system :asdf)))
     2370          ;; invalidate all systems but ASDF itself
     2371          (setf *defined-systems* (make-defined-systems-table))
     2372          (register-system asdf)
     2373          t)))))
     2374
     2375(defmethod perform-plan ((steps list) &key)
     2376  (let ((*package* *package*)
     2377        (*readtable* *readtable*))
     2378    (with-compilation-unit ()
     2379      (loop :for (op . component) :in steps :do
     2380        (loop
     2381          (restart-case
     2382              (progn
     2383                (perform-with-restarts op component)
     2384                (return))
     2385            (retry ()
     2386              :report
     2387              (lambda (s)
     2388                (format s (compatfmt "~@<Retry ~A.~@:>")
     2389                        (operation-description op component))))
     2390            (accept ()
     2391              :report
     2392              (lambda (s)
     2393                (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
     2394                        (operation-description op component)))
     2395              (setf (gethash (type-of op)
     2396                             (component-operation-times component))
     2397                    (get-universal-time))
     2398              (return))))))))
    22162399
    22172400(defmethod operate (operation-class system &rest args
     
    22192402                    &allow-other-keys)
    22202403  (declare (ignore force))
    2221   (let* ((*package* *package*)
    2222          (*readtable* *readtable*)
    2223          (op (apply #'make-instance operation-class
    2224                     :original-initargs args
    2225                     args))
    2226          (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
    2227          (system (if (typep system 'component) system (find-system system))))
    2228     (unless (version-satisfies system version)
    2229       (error 'missing-component-of-version :requires system :version version))
    2230     (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))))))
    2252       (values op steps))))
     2404  (with-system-definitions ()
     2405    (let* ((op (apply 'make-instance operation-class
     2406                      :original-initargs args
     2407                      args))
     2408           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
     2409           (system (etypecase system
     2410                     (system system)
     2411                     ((or string symbol) (find-system system)))))
     2412      (unless (version-satisfies system version)
     2413        (error 'missing-component-of-version :requires system :version version))
     2414      (let ((steps (traverse op system)))
     2415        (when (and (not (equal '("asdf") (component-find-path system)))
     2416                   (find '("asdf") (mapcar 'cdr steps)
     2417                         :test 'equal :key 'component-find-path)
     2418                   (upgrade-asdf))
     2419          ;; If we needed to upgrade ASDF to achieve our goal,
     2420          ;; then do it specially as the first thing, then
     2421          ;; invalidate all existing system
     2422          ;; retry the whole thing with the new OPERATE function,
     2423          ;; which on some implementations
     2424          ;; has a new symbol shadowing the current one.
     2425          (return-from operate
     2426            (apply (find-symbol* 'operate :asdf) operation-class system args)))
     2427        (perform-plan steps)
     2428        (values op steps)))))
    22532429
    22542430(defun* oos (operation-class system &rest args &key force verbose version
    22552431            &allow-other-keys)
    22562432  (declare (ignore force verbose version))
    2257   (apply #'operate operation-class system args))
     2433  (apply 'operate operation-class system args))
    22582434
    22592435(let ((operate-docstring
     
    22822458        operate-docstring))
    22832459
    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."
     2460(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
     2461  "Shorthand for `(operate 'asdf:load-op system)`.
     2462See OPERATE for details."
    22882463  (declare (ignore force verbose version))
    2289   (apply #'operate 'load-op system args)
     2464  (apply 'operate 'load-op system args)
    22902465  t)
    22912466
     
    22952470for details."
    22962471  (declare (ignore force verbose version))
    2297   (apply #'operate 'compile-op system args)
     2472  (apply 'operate 'compile-op system args)
    22982473  t)
    22992474
     
    23032478details."
    23042479  (declare (ignore force verbose version))
    2305   (apply #'operate 'test-op system args)
     2480  (apply 'operate 'test-op system args)
    23062481  t)
    23072482
     
    23102485
    23112486(defun* load-pathname ()
    2312   (let ((pn (or *load-pathname* *compile-file-pathname*)))
    2313     (if *resolve-symlinks*
    2314         (and pn (resolve-symlinks pn))
    2315         pn)))
     2487  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
    23162488
    23172489(defun* determine-system-pathname (pathname pathname-supplied-p)
     
    23292501        (default-directory))))
    23302502
    2331 (defmacro defsystem (name &body options)
    2332   (setf name (coerce-name name))
    2333   (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
    2334                             defsystem-depends-on &allow-other-keys)
    2335       options
    2336     (let ((component-options (remove-keys '(:class) options)))
    2337       `(progn
    2338          ;; system must be registered before we parse the body, otherwise
    2339          ;; we recur when trying to find an existing system of the same name
    2340          ;; to reuse options (e.g. pathname) from
    2341          ,@(loop :for system :in defsystem-depends-on
    2342              :collect `(load-system ',(coerce-name system)))
    2343          (let ((s (system-registered-p ',name)))
    2344            (cond ((and s (eq (type-of (cdr s)) ',class))
    2345                   (setf (car s) (get-universal-time)))
    2346                  (s
    2347                   (change-class (cdr s) ',class))
    2348                  (t
    2349                   (register-system (quote ,name)
    2350                                    (make-instance ',class :name ',name))))
    2351            (%set-system-source-file (load-pathname)
    2352                                     (cdr (system-registered-p ',name))))
    2353          (parse-component-form
    2354           nil (list*
    2355                :module (coerce-name ',name)
    2356                :pathname
    2357                ,(determine-system-pathname pathname pathname-arg-p)
    2358                ',component-options))))))
    2359 
    23602503(defun* class-for-type (parent type)
    23612504  (or (loop :for symbol :in (list
     
    23642507                             (find-symbol* type :asdf))
    23652508        :for class = (and symbol (find-class symbol nil))
    2366         :when (and class (subtypep class 'component))
     2509        :when (and class
     2510                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
     2511                                 class (find-class 'component)))
    23672512        :return class)
    23682513      (and (eq type :file)
    2369            (or (module-default-component-class parent)
     2514           (or (and parent (module-default-component-class parent))
    23702515               (find-class *default-component-class*)))
    23712516      (sysdef-error "don't recognize component type ~A" type)))
     
    24592604              weakly-depends-on
    24602605              depends-on serial in-order-to
     2606              (version nil versionp)
    24612607              ;; list ends
    24622608              &allow-other-keys) options
     
    24712617                       (class-for-type parent type))))
    24722618      (error 'duplicate-names :name name))
     2619
     2620    (when versionp
     2621      (unless (parse-version version nil)
     2622        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
     2623              version name parent)))
    24732624
    24742625    (let* ((other-args (remove-keys
     
    24852636      (when *serial-depends-on*
    24862637        (push *serial-depends-on* depends-on))
    2487       (apply #'reinitialize-instance ret
     2638      (apply 'reinitialize-instance ret
    24882639             :name (coerce-name name)
    24892640             :pathname pathname
     
    25182669      ret)))
    25192670
     2671(defun* do-defsystem (name &rest options
     2672                           &key (pathname nil pathname-arg-p) (class 'system)
     2673                           defsystem-depends-on &allow-other-keys)
     2674  ;; The system must be registered before we parse the body,
     2675  ;; otherwise we recur when trying to find an existing system
     2676  ;; of the same name to reuse options (e.g. pathname) from.
     2677  ;; To avoid infinite recursion in cases where you defsystem a system
     2678  ;; that is registered to a different location to find-system,
     2679  ;; we also need to remember it in a special variable *systems-being-defined*.
     2680  (with-system-definitions ()
     2681    (let* ((name (coerce-name name))
     2682           (registered (system-registered-p name))
     2683           (system (cdr (or registered
     2684                            (register-system (make-instance 'system :name name)))))
     2685           (component-options (remove-keys '(:class) options)))
     2686      (%set-system-source-file (load-pathname) system)
     2687      (setf (gethash name *systems-being-defined*) system)
     2688      (when registered
     2689        (setf (car registered) (get-universal-time)))
     2690      (map () 'load-system defsystem-depends-on)
     2691      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
     2692      ;; since the class might not be defined as part of those.
     2693      (let ((class (class-for-type nil class)))
     2694        (unless (eq (type-of system) class)
     2695          (change-class system class)))
     2696      (parse-component-form
     2697       nil (list*
     2698            :module name
     2699            :pathname (determine-system-pathname pathname pathname-arg-p)
     2700            component-options)))))
     2701
     2702(defmacro defsystem (name &body options)
     2703  `(apply 'do-defsystem ',name ',options))
     2704
    25202705;;;; ---------------------------------------------------------------------------
    25212706;;;; run-shell-command
     
    25352720synchronously execute the result using a Bourne-compatible shell, with
    25362721output to *VERBOSE-OUT*.  Returns the shell's exit code."
    2537   (let ((command (apply #'format nil control-string args)))
     2722  (let ((command (apply 'format nil control-string args)))
    25382723    (asdf-message "; $ ~A~%" command)
    25392724
     
    25532738      exit-code)
    25542739
    2555     #+clisp                     ;XXX not exactly *verbose-out*, I know
    2556     (or (ext:run-shell-command  command :output :terminal :wait t) 0)
     2740    #+clisp                    ;XXX not exactly *verbose-out*, I know
     2741    (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
    25572742
    25582743    #+clozure
     
    25792764    #+sbcl
    25802765    (sb-ext:process-exit-code
    2581      (apply #'sb-ext:run-program
     2766     (apply 'sb-ext:run-program
    25822767            #+win32 "sh" #-win32 "/bin/sh"
    25832768            (list  "-c" command)
     
    25922777      :input nil :output *verbose-out*))
    25932778
    2594     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
     2779    #+xcl
     2780    (ext:run-shell-command command)
     2781
     2782    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
    25952783    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
    25962784
    25972785;;;; ---------------------------------------------------------------------------
    25982786;;;; system-relative-pathname
     2787
     2788(defun* system-definition-pathname (x)
     2789  ;; As of 2.014.8, we mean to make this function obsolete,
     2790  ;; but that won't happen until all clients have been updated.
     2791  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
     2792  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
     2793It used to expose ASDF internals with subtle differences with respect to
     2794user expectations, that have been refactored away since.
     2795We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
     2796for a mostly compatible replacement that we're supporting,
     2797or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
     2798if that's whay you mean." ;;)
     2799  (system-source-file x))
    25992800
    26002801(defmethod system-source-file ((system-name string))
     
    26452846    (:corman :cormanlisp)
    26462847    (:lw :lispworks)
    2647     :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
     2848    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
    26482849
    26492850(defparameter *os-features*
    2650   '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
     2851  '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    26512852    (:solaris :sunos)
    26522853    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
     
    26572858
    26582859(defparameter *architecture-features*
    2659   '((:amd64 :x86-64 :x86_64 :x8664-target)
     2860  '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386)
    26602861    (: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)
     2862    :hppa64 :hppa
     2863    (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
     2864    :sparc64 (:sparc32 :sparc)
    26672865    (:arm :arm-target)
    26682866    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
     2867    :mipsel :mipseb :mips
     2868    :alpha
    26692869    :imach))
    26702870
    26712871(defun* lisp-version-string ()
    26722872  (let ((s (lisp-implementation-version)))
    2673     (declare (ignorable s))
    2674     #+allegro (format nil
    2675                       "~A~A~A~A"
    2676                       excl::*common-lisp-version-number*
    2677                       ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
    2678                       (if (eq excl:*current-case-mode*
    2679                               :case-sensitive-lower) "M" "A")
    2680                       ;; Note if not using International ACL
    2681                       ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
    2682                       (excl:ics-target-case
    2683                        (:-ics "8")
    2684                        (:+ics ""))
    2685                       (if (member :64bit *features*) "-64bit" ""))
    2686     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2687     #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    2688     #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    2689                       ccl::*openmcl-major-version*
    2690                       ccl::*openmcl-minor-version*
    2691                       (logand ccl::fasl-version #xFF))
    2692     #+cmu (substitute #\- #\/ s)
    2693     #+ecl (format nil "~A~@[-~A~]" s
    2694                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    2695                     (when (>= (length vcs-id) 8)
    2696                       (subseq vcs-id 0 8))))
    2697     #+gcl (subseq s (1+ (position #\space s)))
    2698     #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
    2699                (format nil "~D.~D" major minor))
    2700     #+lispworks (format nil "~A~@[~A~]" s
    2701                         (when (member :lispworks-64bit *features*) "-64bit"))
    2702     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
    2703     #+mcl (subseq s 8) ; strip the leading "Version "
    2704     #+(or cormanlisp sbcl scl) s
    2705     #-(or allegro armedbear clisp clozure cmu cormanlisp
    2706           ecl gcl genera lispworks mcl sbcl scl) s))
     2873    (or
     2874     #+allegro (format nil
     2875                       "~A~A~A"
     2876                       excl::*common-lisp-version-number*
     2877                       ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
     2878                       (if (eq excl:*current-case-mode*
     2879                               :case-sensitive-lower) "M" "A")
     2880                       ;; Note if not using International ACL
     2881                       ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     2882                       (excl:ics-target-case
     2883                        (:-ics "8")
     2884                        (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" ""))
     2885     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
     2886     #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     2887     #+clozure (format nil "~d.~d-f~d" ; shorten for windows
     2888                       ccl::*openmcl-major-version*
     2889                       ccl::*openmcl-minor-version*
     2890                       (logand ccl::fasl-version #xFF))
     2891     #+cmu (substitute #\- #\/ s)
     2892     #+ecl (format nil "~A~@[-~A~]" s
     2893                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     2894                     (when (>= (length vcs-id) 8)
     2895                       (subseq vcs-id 0 8))))
     2896     #+gcl (subseq s (1+ (position #\space s)))
     2897     #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
     2898                (format nil "~D.~D" major minor))
     2899     ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")     #+mcl (subseq s 8) ; strip the leading "Version "
     2900     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
     2901     s)))
    27072902
    27082903(defun* first-feature (features)
     
    27292924      ((maybe-warn (value fstring &rest args)
    27302925         (cond (value)
    2731                (t (apply #'warn fstring args)
     2926               (t (apply 'warn fstring args)
    27322927                  "unknown"))))
    27332928    (let ((lisp (maybe-warn (implementation-type)
     
    27542949  #-asdf-unix #\;)
    27552950
     2951;; Note: ASDF may expect user-homedir-pathname to provide the pathname of
     2952;; the current user's home directory, while MCL by default provides the
     2953;; directory from which MCL was started.
     2954;; See http://code.google.com/p/mcl/wiki/Portability
     2955#.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl
     2956      `(defun current-user-homedir-pathname ()
     2957         ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))")))
     2958
    27562959(defun* user-homedir ()
    2757   (truenamize (pathname-directory-pathname (user-homedir-pathname))))
     2960  (truenamize
     2961   (pathname-directory-pathname
     2962    #+mcl (current-user-homedir-pathname)
     2963    #-mcl (user-homedir-pathname))))
    27582964
    27592965(defun* try-directory-subpath (x sub &key type)
     
    27642970    (and ts (values sp ts))))
    27652971(defun* user-configuration-directories ()
    2766   (remove-if
    2767    #'null
    2768    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    2769      `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
    2770        ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
    2771            :for dir :in (split-string dirs :separator ":")
    2772            :collect (try dir "common-lisp/"))
    2773        #+asdf-windows
    2774         ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
    2775             ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    2776            ,(try (getenv "APPDATA") "common-lisp/config/"))
    2777        ,(try (user-homedir) ".config/common-lisp/")))))
     2972  (let ((dirs
     2973         (flet ((try (x sub) (try-directory-subpath x sub)))
     2974           `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
     2975             ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
     2976                 :for dir :in (split-string dirs :separator ":")
     2977                 :collect (try dir "common-lisp/"))
     2978             #+asdf-windows
     2979             ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
     2980                           (getenv "LOCALAPPDATA"))
     2981                       "common-lisp/config/")
     2982                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     2983                 ,(try (or #+lispworks (sys:get-folder-path :appdata)
     2984                           (getenv "APPDATA"))
     2985                           "common-lisp/config/"))
     2986             ,(try (user-homedir) ".config/common-lisp/")))))
     2987    (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
    27782988(defun* system-configuration-directories ()
    27792989  (remove-if
    27802990   #'null
    2781    (append
    2782     #+asdf-windows
    2783     (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    2784       `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
    2785            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    2786         ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    2787     #+asdf-unix
    2788     (list #p"/etc/common-lisp/"))))
     2991   `(#+asdf-windows
     2992     ,(flet ((try (x sub) (try-directory-subpath x sub)))
     2993        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
     2994        (try (or #+lispworks (sys:get-folder-path :common-appdata)
     2995                 (getenv "ALLUSERSAPPDATA")
     2996                 (try (getenv "ALLUSERSPROFILE") "Application Data/"))
     2997             "common-lisp/config/"))
     2998     #+asdf-unix #p"/etc/common-lisp/")))
     2999
    27893000(defun* in-first-directory (dirs x)
    27903001  (loop :for dir :in dirs
     
    28463057    (unless (length=n-p forms 1)
    28473058      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
    2848        description forms))
     3059             description forms))
    28493060    (funcall validator (car forms) :location file)))
    28503061
     
    28583069                             #+clisp '(:circle t :if-does-not-exist :ignore)
    28593070                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
    2860                              #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
     3071                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
     3072                                      '(:resolve-symlinks nil))))))
    28613073
    28623074(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
     
    29043116     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
    29053117     #+asdf-windows
    2906      (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
     3118     (try (or #+lispworks (sys:get-folder-path :local-appdata)
     3119              (getenv "LOCALAPPDATA")
     3120              #+lispworks (sys:get-folder-path :appdata)
     3121              (getenv "APPDATA"))
     3122          "common-lisp" "cache" :implementation)
    29073123     '(:home ".cache" "common-lisp" :implementation))))
    29083124(defvar *system-cache*
     
    30033219                          :directory t :wilden nil))
    30043220            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
    3005             ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
     3221            ((eql :system-cache)
     3222             (warn "Using the :system-cache is deprecated. ~%~
     3223Please remove it from your ASDF configuration")
     3224             (resolve-location *system-cache* :directory t :wilden nil))
    30063225            ((eql :default-directory) (default-directory))))
    30073226         (s (if (and wilden (not (pathnamep x)))
     
    31023321           (when inherit
    31033322             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    3104         string))
     3323                    string))
    31053324           (setf inherit t)
    31063325           (push :inherit-configuration directives))
     
    31113330          (when source
    31123331            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
    3113        string))
     3332                   string))
    31143333          (unless inherit
    31153334            (push :ignore-inherited-configuration directives))
     
    31293348    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
    31303349                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
    3131     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    3132     #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
     3350    ;; The below two are not needed: no precompiled ASDF system there
     3351    ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
     3352    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
    31333353    ;; All-import, here is where we want user stuff to be:
    31343354    :inherit-configuration
     
    31433363
    31443364(defun* user-output-translations-pathname ()
    3145   (in-user-configuration-directory *output-translations-file* ))
     3365  (in-user-configuration-directory *output-translations-file*))
    31463366(defun* system-output-translations-pathname ()
    31473367  (in-system-configuration-directory *output-translations-file*))
     
    32173437                   (funcall collect (list trusrc t)))
    32183438                  (t
    3219                    (let* ((trudst (make-pathname
    3220                                    :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
     3439                   (let* ((trudst (if dst
     3440                                      (resolve-location dst :directory t :wilden t)
     3441                                      trusrc))
    32213442                          (wilddst (merge-pathnames* *wild-file* trudst)))
    32223443                     (funcall collect (list wilddst t))
     
    32723493(defun* apply-output-translations (path)
    32733494  (etypecase path
     3495    #+cormanlisp (t (truenamize path))
    32743496    (logical-pathname
    32753497     path)
     
    33013523
    33023524(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
    3303   (or output-file
     3525  (if (absolute-pathname-p output-file)
     3526      (apply 'compile-file-pathname (lispize-pathname input-file) keys)
    33043527      (apply-output-translations
    33053528       (apply 'compile-file-pathname
     
    33173540
    33183541(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
    3319   (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
     3542  (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
    33203543         (tmp-file (tmpize-pathname output-file))
    33213544         (status :error))
     
    33843607  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
    33853608         (mapped-files (if map-all-source-files *wild-file*
    3386                            (make-pathname :name :wild :version :wild :type fasl-type)))
     3609                           (make-pathname :type fasl-type :defaults *wild-file*)))
    33873610         (destination-directory
    33883611          (if centralize-lisp-binaries
     
    34183641
    34193642(defun* read-little-endian (s &optional (bytes 4))
    3420   (loop
    3421     :for i :from 0 :below bytes
     3643  (loop :for i :from 0 :below bytes
    34223644    :sum (ash (read-byte s) (* 8 i))))
    34233645
     
    34863708    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    34873709    "_sgbak" "autom4te.cache" "cover_db" "_build"
    3488     "debian")) ;; debian often build stuff under the debian directory... BAD.
     3710    "debian")) ;; debian often builds stuff under the debian directory... BAD.
    34893711
    34903712(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    34913713
    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)
     3714(defvar *source-registry* nil
     3715  "Either NIL (for uninitialized), or an equal hash-table, mapping
     3716system names to pathnames of .asd files")
    35023717
    35033718(defun* source-registry-initialized-p ()
    3504   (and *source-registry* t))
     3719  (typep *source-registry* 'hash-table))
    35053720
    35063721(defun* clear-source-registry ()
     
    35083723You might want to call that before you dump an image that would be resumed
    35093724with a different configuration, so the configuration would be re-read then."
    3510   (setf *source-registry* '())
     3725  (setf *source-registry* nil)
    35113726  (values))
    35123727
    35133728(defparameter *wild-asd*
    3514   (make-pathname :directory nil :name :wild :type "asd" :version :newest))
    3515 
    3516 (defun directory-has-asd-files-p (directory)
     3729  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
     3730
     3731(defun directory-asd-files (directory)
    35173732  (ignore-errors
    3518     (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
     3733    (directory* (merge-pathnames* *wild-asd* directory))))
    35193734
    35203735(defun subdirectories (directory)
    35213736  (let* ((directory (ensure-directory-pathname directory))
    3522          #-(or cormanlisp genera)
     3737         #-(or abcl cormanlisp genera xcl)
    35233738         (wild (merge-pathnames*
    3524                 #-(or abcl allegro lispworks scl)
     3739                #-(or abcl allegro cmu lispworks scl xcl)
    35253740                *wild-directory*
    3526                 #+(or abcl allegro lispworks scl) "*.*"
     3741                #+(or abcl allegro cmu lispworks scl xcl) "*.*"
    35273742                directory))
    35283743         (dirs
    3529           #-(or cormanlisp genera)
     3744          #-(or abcl cormanlisp genera xcl)
    35303745          (ignore-errors
    35313746            (directory* wild . #.(or #+clozure '(:directories t :files nil)
    35323747                                     #+mcl '(:directories t))))
     3748          #+(or abcl xcl) (system:list-directory directory)
    35333749          #+cormanlisp (cl::directory-subdirs directory)
    35343750          #+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)))
     3751         #+(or abcl allegro cmu genera lispworks scl xcl)
     3752         (dirs (loop :for x :in dirs
     3753                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
     3754                          #+allegro (excl:probe-directory x)
     3755                          #+(or cmu scl) (directory-pathname-p x)
     3756                          #+genera (getf (cdr x) :directory)
     3757                          #+lispworks (lw:file-directory-p x)
     3758                 :when d :collect #+(or abcl allegro xcl) d
     3759                                  #+genera (ensure-directory-pathname (first x))
     3760                                  #+(or cmu lispworks scl) x)))
    35443761    dirs))
     3762
     3763(defun collect-asds-in-directory (directory collect)
     3764  (map () collect (directory-asd-files directory)))
    35453765
    35463766(defun collect-sub*directories (directory collectp recursep collector)
     
    35513771      (collect-sub*directories subdir collectp recursep collector))))
    35523772
    3553 (defun collect-sub*directories-with-asd
     3773(defun collect-sub*directories-asd-files
    35543774    (directory &key
    35553775     (exclude *default-source-registry-exclusions*)
     
    35573777  (collect-sub*directories
    35583778   directory
    3559    #'directory-has-asd-files-p
     3779   (constantly t)
    35603780   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
    3561    collect))
     3781   #'(lambda (dir) (collect-asds-in-directory dir collect))))
    35623782
    35633783(defun* validate-source-registry-directive (directive)
     
    36043824      :for pos = (position *inter-directory-separator* string :start start) :do
    36053825      (let ((s (subseq string start (or pos end))))
    3606         (cond
    3607          ((equal "" s) ; empty element: inherit
    3608           (when inherit
    3609             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    3610        string))
    3611           (setf inherit t)
    3612           (push ':inherit-configuration directives))
    3613          ((ends-with s "//")
    3614           (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
    3615          (t
    3616           (push `(:directory ,s) directives)))
     3826        (flet ((check (dir)
     3827                 (unless (absolute-pathname-p dir)
     3828                   (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
     3829                 dir))
     3830          (cond
     3831            ((equal "" s) ; empty element: inherit
     3832             (when inherit
     3833               (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     3834                      string))
     3835             (setf inherit t)
     3836             (push ':inherit-configuration directives))
     3837            ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
     3838             (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
     3839            (t
     3840             (push `(:directory ,(check s)) directives))))
    36173841        (cond
    36183842          (pos
     
    36253849(defun* register-asd-directory (directory &key recurse exclude collect)
    36263850  (if (not recurse)
    3627       (funcall collect directory)
    3628       (collect-sub*directories-with-asd
     3851      (collect-asds-in-directory directory collect)
     3852      (collect-sub*directories-asd-files
    36293853       directory :exclude exclude :collect collect)))
    36303854
     
    36463870    #+cmu (:tree #p"modules:")))
    36473871(defun* default-source-registry ()
    3648   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     3872  (flet ((try (x sub) (try-directory-subpath x sub)))
    36493873    `(:source-registry
    3650       #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
     3874      #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
    36513875      (:directory ,(default-directory))
    3652       ,@(let*
    3653          #+asdf-unix
    3654          ((datahome
    3655            (or (getenv "XDG_DATA_HOME")
    3656                (try (user-homedir) ".local/share/")))
    3657           (datadirs
    3658            (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
    3659           (dirs (cons datahome (split-string datadirs :separator ":"))))
    3660          #+asdf-windows
    3661          ((datahome (getenv "APPDATA"))
    3662           (datadir
    3663            #+lispworks (sys:get-folder-path :local-appdata)
    3664            #-lispworks (try (getenv "ALLUSERSPROFILE")
    3665                             "Application Data"))
    3666           (dirs (list datahome datadir)))
    3667          #-(or asdf-unix asdf-windows)
    3668          ((dirs ()))
    3669          (loop :for dir :in dirs
    3670            :collect `(:directory ,(try dir "common-lisp/systems/"))
    3671            :collect `(:tree ,(try dir "common-lisp/source/"))))
     3876      ,@(loop :for dir :in
     3877          `(#+asdf-unix
     3878            ,@`(,(or (getenv "XDG_DATA_HOME")
     3879                     (try (user-homedir) ".local/share/"))
     3880                ,@(split-string (or (getenv "XDG_DATA_DIRS")
     3881                                    "/usr/local/share:/usr/share")
     3882                                :separator ":"))
     3883            #+asdf-windows
     3884            ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata)
     3885                     (getenv "LOCALAPPDATA"))
     3886                ,(or #+lispworks (sys:get-folder-path :appdata)
     3887                     (getenv "APPDATA"))
     3888                ,(or #+lispworks (sys:get-folder-path :common-appdata)
     3889                     (getenv "ALLUSERSAPPDATA")
     3890                     (try (getenv "ALLUSERSPROFILE") "Application Data/"))))
     3891          :collect `(:directory ,(try dir "common-lisp/systems/"))
     3892          :collect `(:tree ,(try dir "common-lisp/source/")))
    36723893      :inherit-configuration)))
    36733894(defun* user-source-registry ()
     
    37583979;; Will read the configuration and initialize all internal variables,
    37593980;; 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
     3981(defun* compute-source-registry (&optional parameter (registry *source-registry*))
     3982  (dolist (entry (flatten-source-registry parameter))
     3983    (destructuring-bind (directory &key recurse exclude) entry
     3984      (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
    37643985        (register-asd-directory
    3765          directory
    3766          :recurse recurse :exclude exclude :collect #'collect)))))
     3986         directory :recurse recurse :exclude exclude :collect
     3987         #'(lambda (asd)
     3988             (let ((name (pathname-name asd)))
     3989               (cond
     3990                 ((gethash name registry) ; already shadowed by something else
     3991                  nil)
     3992                 ((gethash name h) ; conflict at current level
     3993                  (when *asdf-verbose*
     3994                    (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
     3995                                found several entries for ~A - picking ~S over ~S~:>")
     3996                          directory recurse name (gethash name h) asd)))
     3997                 (t
     3998                  (setf (gethash name registry) asd)
     3999                  (setf (gethash name h) asd))))))
     4000        h)))
     4001  (values))
    37674002
    37684003(defvar *source-registry-parameter* nil)
    37694004
    37704005(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
    3771   (setf *source-registry-parameter* parameter
    3772         (source-registry) (compute-source-registry parameter)))
     4006  (setf *source-registry-parameter* parameter)
     4007  (setf *source-registry* (make-hash-table :test 'equal))
     4008  (compute-source-registry parameter))
    37734009
    37744010;; Checks an initial variable to see whether the state is initialized
     
    37814017;; initialize-source-registry directly with your parameter.
    37824018(defun* ensure-source-registry (&optional parameter)
    3783   (if (source-registry-initialized-p)
    3784       (source-registry)
    3785       (initialize-source-registry parameter)))
     4019  (unless (source-registry-initialized-p)
     4020    (initialize-source-registry parameter))
     4021  (values))
    37864022
    37874023(defun* sysdef-source-registry-search (system)
    37884024  (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))
     4025  (values (gethash (coerce-name system) *source-registry*)))
    37934026
    37944027(defun* clear-configuration ()
     
    37964029  (clear-output-translations))
    37974030
     4031
     4032;;; ECL support for COMPILE-OP / LOAD-OP
     4033;;;
     4034;;; In ECL, these operations produce both FASL files and the
     4035;;; object files that they are built from. Having both of them allows
     4036;;; us to later on reuse the object files for bundles, libraries,
     4037;;; standalone executables, etc.
     4038;;;
     4039;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
     4040;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
     4041;;;
     4042#+ecl
     4043(progn
     4044  (setf *compile-op-compile-file-function*
     4045        (lambda (input-file &rest keys &key output-file &allow-other-keys)
     4046          (declare (ignore output-file))
     4047          (multiple-value-bind (object-file flags1 flags2)
     4048              (apply 'compile-file* input-file :system-p t keys)
     4049            (values (and object-file
     4050                         (c::build-fasl (compile-file-pathname object-file :type :fasl)
     4051                                        :lisp-files (list object-file))
     4052                         object-file)
     4053                    flags1
     4054                    flags2))))
     4055
     4056  (defmethod output-files ((operation compile-op) (c cl-source-file))
     4057    (declare (ignorable operation))
     4058    (let ((p (lispize-pathname (component-pathname c))))
     4059      (list (compile-file-pathname p :type :object)
     4060            (compile-file-pathname p :type :fasl))))
     4061
     4062  (defmethod perform ((o load-op) (c cl-source-file))
     4063    (map () #'load
     4064         (loop :for i :in (input-files o c)
     4065           :unless (string= (pathname-type i) "fas")
     4066           :collect (compile-file-pathname (lispize-pathname i))))))
     4067
    37984068;;;; -----------------------------------------------------------------
    37994069;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
    38004070;;;;
     4071(defvar *require-asdf-operator* 'load-op)
     4072
    38014073(defun* module-provide-asdf (name)
    38024074  (handler-bind
     
    38074079                          name e))))
    38084080    (let ((*verbose-out* (make-broadcast-stream))
    3809            (system (find-system (string-downcase name) nil)))
     4081          (system (find-system (string-downcase name) nil)))
    38104082      (when system
    3811         (load-system system)))))
     4083        (operate *require-asdf-operator* system :verbose nil)
     4084        t))))
    38124085
    38134086#+(or abcl clisp clozure cmu ecl sbcl)
Note: See TracChangeset for help on using the changeset viewer.