Changeset 14920


Ignore:
Timestamp:
Jul 28, 2011, 1:12:21 PM (13 years ago)
Author:
R. Matthew Emerson
Message:

ASDF 2.017 from upstream.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/tools/asdf.lisp

    r14818 r14920  
    11;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.016: Another System Definition Facility.
     2;;; This is ASDF 2.017: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
    … …  
    5151
    5252#-(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.")
     53(error "ASDF is not supported on your implementation. Please help us port it.")
    5454
    5555#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
    … …  
    6363                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    6464  #+(and ecl (not ecl-bytecmp)) (require :cmp)
     65  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
     66  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
     67            (and (= system::*gcl-major-version* 2)
     68                 (< system::*gcl-minor-version* 7)))
     69    (pushnew :gcl-pre2.7 *features*))
    6570  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
    6671  #+(or unix cygwin) (pushnew :asdf-unix *features*)
    … …  
    8590  ;; Has to be inside the eval-when to make Lispworks happy (!)
    8691  (defmacro compatfmt (format)
    87     #-genera format
    88     #+genera
     92    #-(or gcl genera) format
     93    #+(or gcl genera)
    8994    (loop :for (unsupported . replacement) :in
    90       '(("~@<" . "")
    91         ("; ~@;" . "; ")
    92         ("~3i~_" . "")
    93         ("~@:>" . "")
    94         ("~:>" . "")) :do
     95      `(("~3i~_" . "")
     96        #+genera
     97        ,@(("~@<" . "")
     98           ("; ~@;" . "; ")
     99           ("~@:>" . "")
     100           ("~:>" . ""))) :do
    95101      (loop :for found = (search unsupported format) :while found :do
    96102        (setf format
    … …  
    107113         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    108114         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    109          (asdf-version "2.016")
     115         (asdf-version "2.017")
    110116         (existing-asdf (find-class 'component nil))
    111117         (existing-version *asdf-version*)
    … …  
    195201               (loop :for x :in newly-exported-symbols :do
    196202                 (export (intern* x package)))))
    197            (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
     203           (ensure-package (name &key nicknames use unintern fmakunbound
     204                                 shadow export redefined-functions)
    198205             (let* ((p (ensure-exists name nicknames use)))
    199206               (ensure-unintern p unintern)
    200207               (ensure-shadow p shadow)
    201208               (ensure-export p export)
    202                (ensure-fmakunbound p fmakunbound)
     209               (ensure-fmakunbound p (append fmakunbound redefined-functions))
    203210               p)))
    204211        (macrolet
    … …  
    208215                   ',name :nicknames ',nicknames :use ',use :export ',export
    209216                   :shadow ',shadow
    210                    :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
    211                    :fmakunbound ',(append fmakunbound))))
     217                   :unintern ',unintern
     218                   :redefined-functions ',redefined-functions
     219                   :fmakunbound ',fmakunbound)))
    212220          (pkgdcl
    213221           :asdf
    … …  
    343351            #:ensure-directory-pathname
    344352            #:getenv
    345             ;; #:get-uid
    346353            ;; #:length=n-p
    347354            ;; #:find-symbol*
    … …  
    368375;;;; User-visible parameters
    369376;;;;
    370 (defun asdf-version ()
    371   "Exported interface to the version of ASDF currently installed. A string.
    372 You can compare this string with e.g.:
    373 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
    374   *asdf-version*)
    375 
    376377(defvar *resolve-symlinks* t
    377378  "Determine whether or not ASDF resolves symlinks when defining systems.
    … …  
    416417                condition-format condition-location
    417418                coerce-name)
    418          #-cormanlisp
     419         #-(or cormanlisp gcl-pre2.7)
    419420         (ftype (function (t t) t) (setf module-components-by-name)))
    420421
    421422;;;; -------------------------------------------------------------------------
    422 ;;;; Compatibility with Corman Lisp
     423;;;; Compatibility various implementations
    423424#+cormanlisp
    424425(progn
    425426  (deftype logical-pathname () nil)
    426   (defun make-broadcast-stream () *error-output*)
    427   (defun file-namestring (p)
     427  (defun* make-broadcast-stream () *error-output*)
     428  (defun* file-namestring (p)
    428429    (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)))
     430    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
     431
     432#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
     433      (read-from-string
     434       "(eval-when (:compile-toplevel :load-toplevel :execute)
     435          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
     436          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
     437          ;; Note: ASDF may expect user-homedir-pathname to provide
     438          ;; the pathname of the current user's home directory, whereas
     439          ;; MCL by default provides the directory from which MCL was started.
     440          ;; See http://code.google.com/p/mcl/wiki/Portability
     441          (defun current-user-homedir-pathname ()
     442            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
     443          (defun probe-posix (posix-namestring)
     444            \"If a file exists for the posix namestring, return the pathname\"
     445            (ccl::with-cstrs ((cpath posix-namestring))
     446              (ccl::rlet ((is-dir :boolean)
     447                          (fsref :fsref))
     448                (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
     449                  (ccl::%path-from-fsref fsref is-dir))))))"))
    439450
    440451;;;; -------------------------------------------------------------------------
    … …  
    445456       `(defmacro ,def* (name formals &rest rest)
    446457          `(progn
    447              #+(or ecl gcl) (fmakunbound ',name)
     458             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
    448459             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
    449460             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
    … …  
    516527
    517528(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    518   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
    519 does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
     529  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
     530if the SPECIFIED pathname does not have an absolute directory,
     531then the HOST and DEVICE both come from the DEFAULTS, whereas
     532if the SPECIFIED pathname does have an absolute directory,
     533then the HOST and DEVICE both come from the SPECIFIED.
    520534Also, if either argument is NIL, then the other argument is returned unmodified."
    521535  (when (null specified) (return-from merge-pathnames* defaults))
    … …  
    560574                   :defaults pathname)))
    561575
    562 
    563576(define-modify-macro appendf (&rest args)
    564577  append "Append onto list") ;; only to be used on short lists.
    … …  
    660673    :unless (eq k key)
    661674    :append (list k v)))
    662 
    663 #+mcl
    664 (eval-when (:compile-toplevel :load-toplevel :execute)
    665   (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
    666675
    667676(defun* getenv (x)
    … …  
    731740#+genera
    732741(unless (fboundp 'ensure-directories-exist)
    733   (defun ensure-directories-exist (path)
     742  (defun* ensure-directories-exist (path)
    734743    (fs:create-directories-recursively (pathname path))))
    735744
    … …  
    761770     :collect form)))
    762771
    763 #+asdf-unix
    764 (progn
    765   #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
    766                   '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
    767   (defun* get-uid ()
    768     #+allegro (excl.osi:getuid)
    769     #+ccl (ccl::getuid)
    770     #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
    771                   :for f = (ignore-errors (read-from-string s))
    772                   :when f :return (funcall f))
    773     #+(or cmu scl) (unix:unix-getuid)
    774     #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
    775                    '(ffi:c-inline () () :int "getuid()" :one-liner t)
    776                    '(ext::getuid))
    777     #+sbcl (sb-unix:unix-getuid)
    778     #-(or allegro ccl clisp cmu ecl sbcl scl)
    779     (let ((uid-string
    780            (with-output-to-string (*verbose-out*)
    781              (run-shell-command "id -ur"))))
    782       (with-input-from-string (stream uid-string)
    783         (read-line stream)
    784         (handler-case (parse-integer (read-line stream))
    785           (error () (error "Unable to find out user ID")))))))
    786 
    787772(defun* pathname-root (pathname)
    788773  (make-pathname :directory '(:absolute)
    … …  
    799784    (string (probe-file* (parse-namestring p)))
    800785    (pathname (unless (wild-pathname-p p)
    801                 #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
     786                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
     787                      '(probe-file p)
    802788                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
    803789                                   `(ignore-errors (,it p)))
    804790                      '(ignore-errors (truename p)))))))
    805791
    806 (defun* truenamize (p)
     792(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
    807793  "Resolve as much of a pathname as possible"
    808794  (block nil
    809     (when (typep p '(or null logical-pathname)) (return p))
    810     (let* ((p (merge-pathnames* p))
    811            (directory (pathname-directory p)))
     795    (when (typep pathname '(or null logical-pathname)) (return pathname))
     796    (let ((p (merge-pathnames* pathname defaults)))
    812797      (when (typep p 'logical-pathname) (return p))
    813798      (let ((found (probe-file* p)))
    814799        (when found (return found)))
    815       #-(or cmu sbcl scl) (when (stringp directory) (return p))
    816       (when (not (eq :absolute (car directory))) (return p))
     800      (unless (absolute-pathname-p p)
     801        (let ((true-defaults (ignore-errors (truename defaults))))
     802          (when true-defaults
     803            (setf p (merge-pathnames pathname true-defaults)))))
     804      (unless (absolute-pathname-p p) (return p))
    817805      (let ((sofar (probe-file* (pathname-root p))))
    818806        (unless sofar (return p))
    … …  
    825813                                 :version (pathname-version p))
    826814                  sofar)))
    827           (loop :for component :in (cdr directory)
     815          (loop :with directory = (normalize-pathname-directory-component
     816                                   (pathname-directory p))
     817            :for component :in (cdr directory)
    828818            :for rest :on (cdr directory)
    829819            :for more = (probe-file*
    … …  
    848838      path))
    849839
    850 (defun ensure-pathname-absolute (path)
     840(defun* ensure-pathname-absolute (path)
    851841  (cond
    852842    ((absolute-pathname-p path) path)
    … …  
    878868
    879869#-scl
    880 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
     870(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
    881871  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
    882872    (last-char (namestring foo))))
    … …  
    962952(defgeneric* (setf component-property) (new-value component property))
    963953
    964 (eval-when (:compile-toplevel :load-toplevel :execute)
     954(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
    965955  (defgeneric* (setf module-components-by-name) (new-value module)))
    966956
    … …  
    12711261      (let ((pathname
    12721262             (merge-pathnames*
    1273              (component-relative-pathname component)
    1274              (pathname-directory-pathname (component-parent-pathname component)))))
     1263              (component-relative-pathname component)
     1264              (pathname-directory-pathname (component-parent-pathname component)))))
    12751265        (unless (or (null pathname) (absolute-pathname-p pathname))
    12761266          (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
    … …  
    13131303  (version-satisfies (component-version c) version))
    13141304
    1315 (defun parse-version (string &optional on-error)
     1305(defun* asdf-version ()
     1306  "Exported interface to the version of ASDF currently installed. A string.
     1307You can compare this string with e.g.:
     1308(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
     1309  *asdf-version*)
     1310
     1311(defun* parse-version (string &optional on-error)
    13161312  "Parse a version string as a series of natural integers separated by dots.
    13171313Return a (non-null) list of integers if the string is valid, NIL otherwise.
    … …  
    14281424  (block nil
    14291425    (when (directory-pathname-p defaults)
    1430       (let ((file
    1431              (make-pathname
    1432               :defaults defaults :version :newest :case :local
    1433               :name name
    1434               :type "asd")))
     1426      (let ((file (make-pathname
     1427                   :defaults defaults :name name
     1428                   :version :newest :case :local :type "asd")))
    14351429        (when (probe-file* file)
    14361430          (return file)))
    … …  
    21142108          :initform nil)))
    21152109
    2116 (defun output-file (operation component)
     2110(defun* output-file (operation component)
    21172111  "The unique output file of performing OPERATION on COMPONENT"
    21182112  (let ((files (output-files operation component)))
    … …  
    21452139        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    21462140    (multiple-value-bind (output warnings-p failure-p)
    2147         (apply *compile-op-compile-file-function* source-file :output-file output-file
    2148                (compile-op-flags operation))
     2141        (apply *compile-op-compile-file-function* source-file
     2142               :output-file output-file (compile-op-flags operation))
    21492143      (unless output
    21502144        (error 'compile-error :component c :operation operation))
    … …  
    23672361           (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
    23682362                         version new-version)))
    2369         (let ((asdf (find-system :asdf)))
     2363        (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
    23702364          ;; invalidate all systems but ASDF itself
    23712365          (setf *defined-systems* (make-defined-systems-table))
    … …  
    26032597              perform explain output-files operation-done-p
    26042598              weakly-depends-on
    2605               depends-on serial in-order-to
     2599              depends-on serial in-order-to do-first
    26062600              (version nil versionp)
    26072601              ;; list ends
    … …  
    26642658             `((compile-op (compile-op ,@depends-on))
    26652659               (load-op (load-op ,@depends-on)))))
    2666       (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
     2660      (setf (component-do-first ret)
     2661            (union-of-dependencies
     2662             do-first
     2663             `((compile-op (load-op ,@depends-on)))))
    26672664
    26682665      (%refresh-component-inline-methods ret rest)
    … …  
    27482745                                 :wait t)))
    27492746
     2747    #+(or cmu scl)
     2748    (ext:process-exit-code
     2749     (ext:run-program
     2750      "/bin/sh"
     2751      (list  "-c" command)
     2752      :input nil :output *verbose-out*))
     2753
    27502754    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    27512755    (si:system command)
    … …  
    27622766     :output-stream *verbose-out*)
    27632767
     2768    #+mcl
     2769    (ccl::with-cstrs ((%command command)) (_system %command))
     2770
    27642771    #+sbcl
    27652772    (sb-ext:process-exit-code
    … …  
    27702777            #+win32 '(:search t) #-win32 nil))
    27712778
    2772     #+(or cmu scl)
    2773     (ext:process-exit-code
    2774      (ext:run-program
    2775       "/bin/sh"
    2776       (list  "-c" command)
    2777       :input nil :output *verbose-out*))
    2778 
    27792779    #+xcl
    27802780    (ext:run-shell-command command)
    27812781
    2782     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
     2782    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
    27832783    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
    27842784
    … …  
    28082808directory in which the system specification (.asd file) is
    28092809located."
    2810      (make-pathname :name nil
    2811                  :type nil
    2812                  :defaults (system-source-file system-designator)))
     2810  (pathname-directory-pathname (system-source-file system-designator)))
    28132811
    28142812(defun* relativize-directory (directory)
    … …  
    28372835;;;
    28382836;;; produce a string to identify current implementation.
    2839 ;;; Initially stolen from SLIME's SWANK, hacked since.
    2840 
    2841 (defparameter *implementation-features*
    2842   '((:abcl :armedbear)
    2843     (:acl :allegro)
    2844     (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
    2845     (:ccl :clozure)
    2846     (:corman :cormanlisp)
    2847     (:lw :lispworks)
    2848     :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
    2849 
    2850 (defparameter *os-features*
    2851   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    2852     (:solaris :sunos)
    2853     (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
    2854     (:macosx :darwin :darwin-target :apple)
    2855     :freebsd :netbsd :openbsd :bsd
    2856     :unix
    2857     :genera))
    2858 
    2859 (defparameter *architecture-features*
    2860   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386)
    2861     (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
    2862     :hppa64 :hppa
    2863     (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
    2864     :sparc64 (:sparc32 :sparc)
    2865     (:arm :arm-target)
    2866     (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
    2867     :mipsel :mipseb :mips
    2868     :alpha
    2869     :imach))
    2870 
    2871 (defun* lisp-version-string ()
     2837;;; Initially stolen from SLIME's SWANK, rewritten since.
     2838;;; The (car '(...)) idiom avoids unreachable code warnings.
     2839
     2840(defparameter *implementation-type*
     2841  (car '(#+abcl :abcl #+allegro :acl
     2842         #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu
     2843         #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl
     2844         #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl)))
     2845
     2846(defparameter *operating-system*
     2847  (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win
     2848         #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd.
     2849         #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd
     2850         #+(or solaris sunos) :solaris
     2851         #+(or freebsd netbsd openbsd bsd) :bsd
     2852         #+unix :unix
     2853         #+genera :genera)))
     2854
     2855(defparameter *architecture*
     2856  (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64
     2857         #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86
     2858         #+hppa64 :hppa64 #+hppa :hppa
     2859         #+(or ppc64 ppc64-target) :ppc64
     2860         #+(or ppc32 ppc32-target ppc powerpc) :ppc32
     2861         #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32
     2862         #+(or arm arm-target) :arm
     2863         #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java
     2864         #+mipsel :mispel #+mipseb :mipseb #+mips :mips
     2865         #+alpha :alpha #+imach :imach)))
     2866
     2867(defparameter *lisp-version-string*
    28722868  (let ((s (lisp-implementation-version)))
    28732869    (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" ""))
     2870     #+allegro
     2871     (format nil "~A~A~@[~A~]"
     2872             excl::*common-lisp-version-number*
     2873             ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
     2874             (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
     2875             ;; Note if not using International ACL
     2876             ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     2877             (excl:ics-target-case (:-ics "8")))
    28852878     #+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))
     2879     #+clisp
     2880     (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     2881     #+clozure
     2882     (format nil "~d.~d-f~d" ; shorten for windows
     2883             ccl::*openmcl-major-version*
     2884             ccl::*openmcl-minor-version*
     2885             (logand ccl::fasl-version #xFF))
    28912886     #+cmu (substitute #\- #\/ s)
    28922887     #+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))))
     2888                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     2889                     (subseq vcs-id 0 (min (length vcs-id) 8))))
    28962890     #+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
     2891     #+genera
     2892     (multiple-value-bind (major minor) (sct:get-system-version "System")
     2893       (format nil "~D.~D" major minor))
     2894     #+mcl (subseq s 8) ; strip the leading "Version "
    29012895     s)))
    29022896
    2903 (defun* first-feature (features)
    2904   (labels
    2905       ((fp (thing)
    2906          (etypecase thing
    2907            (symbol
    2908             (let ((feature (find thing *features*)))
    2909               (when feature (return-from fp feature))))
    2910            ;; allows features to be lists of which the first
    2911            ;; member is the "main name", the rest being aliases
    2912            (cons
    2913             (dolist (subf thing)
    2914               (when (find subf *features*) (return-from fp (first thing))))))
    2915          nil))
    2916     (loop :for f :in features
    2917       :when (fp f) :return :it)))
    2918 
    29192897(defun* implementation-type ()
    2920   (first-feature *implementation-features*))
     2898  *implementation-type*)
    29212899
    29222900(defun* implementation-identifier ()
    2923   (labels
    2924       ((maybe-warn (value fstring &rest args)
    2925          (cond (value)
    2926                (t (apply 'warn fstring args)
    2927                   "unknown"))))
    2928     (let ((lisp (maybe-warn (implementation-type)
    2929                             (compatfmt "~@<No implementation feature found in ~a.~@:>")
    2930                             *implementation-features*))
    2931           (os   (maybe-warn (first-feature *os-features*)
    2932                             (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))
    2933           (arch (or #-clisp
    2934                     (maybe-warn (first-feature *architecture-features*)
    2935                                 (compatfmt "~@<No architecture feature found in ~a.~@:>")
    2936                                 *architecture-features*)))
    2937           (version (maybe-warn (lisp-version-string)
    2938                                "Don't know how to get Lisp implementation version.")))
    2939       (substitute-if
    2940        #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
    2941        (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
     2901  (substitute-if
     2902   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
     2903   (format nil "~(~a~@{~@[-~a~]~}~)"
     2904           (or *implementation-type* (lisp-implementation-type))
     2905           (or *lisp-version-string* (lisp-implementation-version))
     2906           (or *operating-system* (software-type))
     2907           (or *architecture* (machine-type)))))
    29422908
    29432909
    … …  
    29482914  #+asdf-unix #\:
    29492915  #-asdf-unix #\;)
    2950 
    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))")))
    29582916
    29592917(defun* user-homedir ()
    … …  
    31223080          "common-lisp" "cache" :implementation)
    31233081     '(:home ".cache" "common-lisp" :implementation))))
    3124 (defvar *system-cache*
    3125   ;; No good default, plus there's a security problem
    3126   ;; with other users messing with such directories.
    3127   *user-cache*)
    31283082
    31293083(defun* output-translations ()
    … …  
    31563110                resolve-location))
    31573111
    3158 (defun* resolve-relative-location-component (super x &key directory wilden)
    3159   (let* ((r (etypecase x
    3160               (pathname x)
    3161               (string x)
    3162               (cons
    3163                (return-from resolve-relative-location-component
    3164                  (if (null (cdr x))
     3112(defun* resolve-relative-location-component (x &key directory wilden)
     3113  (let ((r (etypecase x
     3114             (pathname x)
     3115             (string (coerce-pathname x :type (when directory :directory)))
     3116             (cons
     3117              (if (null (cdr x))
     3118                  (resolve-relative-location-component
     3119                   (car x) :directory directory :wilden wilden)
     3120                  (let* ((car (resolve-relative-location-component
     3121                               (car x) :directory t :wilden nil)))
     3122                    (merge-pathnames*
    31653123                     (resolve-relative-location-component
    3166                       super (car x) :directory directory :wilden wilden)
    3167                      (let* ((car (resolve-relative-location-component
    3168                                   super (car x) :directory t :wilden nil))
    3169                             (cdr (resolve-relative-location-component
    3170                                   (merge-pathnames* car super) (cdr x)
    3171                                   :directory directory :wilden wilden)))
    3172                        (merge-pathnames* cdr car)))))
    3173               ((eql :default-directory)
    3174                (relativize-pathname-directory (default-directory)))
    3175               ((eql :*/) *wild-directory*)
    3176               ((eql :**/) *wild-inferiors*)
    3177               ((eql :*.*.*) *wild-file*)
    3178               ((eql :implementation) (implementation-identifier))
    3179               ((eql :implementation-type) (string-downcase (implementation-type)))
    3180               #+asdf-unix
    3181               ((eql :uid) (princ-to-string (get-uid)))))
    3182          (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
    3183          (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
    3184     (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    3185       (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))
    3186     (merge-pathnames* s super)))
     3124                      (cdr x) :directory directory :wilden wilden)
     3125                     car))))
     3126             ((eql :default-directory)
     3127              (relativize-pathname-directory (default-directory)))
     3128             ((eql :*/) *wild-directory*)
     3129             ((eql :**/) *wild-inferiors*)
     3130             ((eql :*.*.*) *wild-file*)
     3131             ((eql :implementation)
     3132              (coerce-pathname (implementation-identifier) :type :directory))
     3133             ((eql :implementation-type)
     3134              (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
     3135    (when (absolute-pathname-p r)
     3136      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
     3137    (if (or (pathnamep x) (not wilden)) r (wilden r))))
    31873138
    31883139(defvar *here-directory* nil
    … …  
    31953146          (etypecase x
    31963147            (pathname x)
    3197             (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
     3148            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
     3149                      #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
     3150                      (if directory (ensure-directory-pathname p) p)))
    31983151            (cons
    31993152             (return-from resolve-absolute-location-component
    … …  
    32013154                   (resolve-absolute-location-component
    32023155                    (car x) :directory directory :wilden wilden)
    3203                    (let* ((car (resolve-absolute-location-component
    3204                                 (car x) :directory t :wilden nil))
    3205                           (cdr (resolve-relative-location-component
    3206                                 car (cdr x) :directory directory :wilden wilden)))
    3207                      (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
     3156                   (merge-pathnames*
     3157                    (resolve-relative-location-component
     3158                     (cdr x) :directory directory :wilden wilden)
     3159                    (resolve-absolute-location-component
     3160                     (car x) :directory t :wilden nil)))))
    32083161            ((eql :root)
    32093162             ;; special magic! we encode such paths as relative pathnames,
    … …  
    32203173            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
    32213174            ((eql :system-cache)
    3222              (warn "Using the :system-cache is deprecated. ~%~
    3223 Please remove it from your ASDF configuration")
    3224              (resolve-location *system-cache* :directory t :wilden nil))
     3175             (error "Using the :system-cache is deprecated. ~%~
     3176Please remove it from your ASDF configuration"))
    32253177            ((eql :default-directory) (default-directory))))
    32263178         (s (if (and wilden (not (pathnamep x)))
    … …  
    32283180                r)))
    32293181    (unless (absolute-pathname-p s)
    3230       (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))
     3182      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
    32313183    s))
    32323184
    … …  
    32403192        :for dir = (and (or morep directory) t)
    32413193        :for wild = (and wilden (not morep))
    3242         :do (setf path (resolve-relative-location-component
    3243                         path component :directory dir :wilden wild))
     3194        :do (setf path (merge-pathnames*
     3195                        (resolve-relative-location-component
     3196                         component :directory dir :wilden wild)
     3197                        path))
    32443198        :finally (return path))))
    32453199
    … …  
    35243478(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
    35253479  (if (absolute-pathname-p output-file)
    3526       (apply 'compile-file-pathname (lispize-pathname input-file) keys)
     3480      ;; what cfp should be doing, w/ mp* instead of mp
     3481      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
     3482             (defaults (make-pathname
     3483                        :type type :defaults (merge-pathnames* input-file))))
     3484        (merge-pathnames* output-file defaults))
    35273485      (apply-output-translations
    3528        (apply 'compile-file-pathname
    3529               (truenamize (lispize-pathname input-file))
    3530               keys))))
     3486       (apply 'compile-file-pathname input-file keys))))
    35313487
    35323488(defun* tmpize-pathname (x)
    … …  
    37293685  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
    37303686
    3731 (defun directory-asd-files (directory)
    3732   (ignore-errors
    3733     (directory* (merge-pathnames* *wild-asd* directory))))
    3734 
    3735 (defun subdirectories (directory)
     3687(defun* filter-logical-directory-results (directory entries merger)
     3688  (if (typep directory 'logical-pathname)
     3689      ;; Try hard to not resolve logical-pathname into physical pathnames;
     3690      ;; otherwise logical-pathname users/lovers will be disappointed.
     3691      ;; If directory* could use some implementation-dependent magic,
     3692      ;; we will have logical pathnames already; otherwise,
     3693      ;; we only keep pathnames for which specifying the name and
     3694      ;; translating the LPN commute.
     3695      (loop :for f :in entries
     3696        :for p = (or (and (typep f 'logical-pathname) f)
     3697                     (let* ((u (ignore-errors (funcall merger f))))
     3698                       (and u (equal (ignore-errors (truename u)) f) u)))
     3699        :when p :collect p)
     3700      entries))
     3701
     3702(defun* directory-files (directory &optional (pattern *wild-file*))
     3703  (when (wild-pathname-p directory)
     3704    (error "Invalid wild in ~S" directory))
     3705  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
     3706    (error "Invalid file pattern ~S" pattern))
     3707  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
     3708    (filter-logical-directory-results
     3709     directory entries
     3710     #'(lambda (f)
     3711         (make-pathname :defaults directory :version (pathname-version f)
     3712                        :name (pathname-name f) :type (pathname-type f))))))
     3713
     3714(defun* directory-asd-files (directory)
     3715  (directory-files directory *wild-asd*))
     3716
     3717(defun* subdirectories (directory)
    37363718  (let* ((directory (ensure-directory-pathname directory))
    37373719         #-(or abcl cormanlisp genera xcl)
    … …  
    37593741                                  #+genera (ensure-directory-pathname (first x))
    37603742                                  #+(or cmu lispworks scl) x)))
    3761     dirs))
    3762 
    3763 (defun collect-asds-in-directory (directory collect)
     3743    (filter-logical-directory-results
     3744     directory dirs
     3745     (let ((prefix (normalize-pathname-directory-component
     3746                    (pathname-directory directory))))
     3747       #'(lambda (d)
     3748           (let ((dir (normalize-pathname-directory-component
     3749                       (pathname-directory d))))
     3750             (and (consp dir) (consp (cdr dir))
     3751                  (make-pathname
     3752                   :defaults directory :name nil :type nil :version nil
     3753                   :directory (append prefix (last dir))))))))))
     3754
     3755(defun* collect-asds-in-directory (directory collect)
    37643756  (map () collect (directory-asd-files directory)))
    37653757
    3766 (defun collect-sub*directories (directory collectp recursep collector)
     3758(defun* collect-sub*directories (directory collectp recursep collector)
    37673759  (when (funcall collectp directory)
    37683760    (funcall collector directory))
    … …  
    37713763      (collect-sub*directories subdir collectp recursep collector))))
    37723764
    3773 (defun collect-sub*directories-asd-files
     3765(defun* collect-sub*directories-asd-files
    37743766    (directory &key
    37753767     (exclude *default-source-registry-exclusions*)
    … …  
    39863978         directory :recurse recurse :exclude exclude :collect
    39873979         #'(lambda (asd)
    3988              (let ((name (pathname-name asd)))
     3980             (let* ((name (pathname-name asd))
     3981                    (name (if (typep asd 'logical-pathname)
     3982                              ;; logical pathnames are upper-case,
     3983                              ;; at least in the CLHS and on SBCL,
     3984                              ;; yet (coerce-name :foo) is lower-case.
     3985                              ;; won't work well with (load-system "Foo")
     3986                              ;; instead of (load-system 'foo)
     3987                              (string-downcase name)
     3988                              name)))
    39893989               (cond
    39903990                 ((gethash name registry) ; already shadowed by something else
Note: See TracChangeset for help on using the changeset viewer.