Changeset 14818


Ignore:
Timestamp:
Jun 8, 2011, 2:19:26 AM (8 years ago)
Author:
rme
Message:

ASDF 2.016 from upstream.

File:
1 edited

Legend:

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

    r14789 r14818  
    11;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.015: Another System Definition Facility.
     2;;; This is ASDF 2.016: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    8080  (defvar *upgraded-p* nil)
    8181  (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))
    8284  ;; Strip out formatting that is not supported on Genera.
    8385  ;; Has to be inside the eval-when to make Lispworks happy (!)
     
    105107         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    106108         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    107          (asdf-version "2.015")
    108          (existing-asdf (fboundp 'find-system))
     109         (asdf-version "2.016")
     110         (existing-asdf (find-class 'component nil))
    109111         (existing-version *asdf-version*)
    110112         (already-there (equal asdf-version existing-version)))
     
    116118      (labels
    117119          ((present-symbol-p (symbol package)
    118              (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
     120             (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
    119121           (present-symbols (package)
    120122             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
     
    146148                   (t
    147149                    (make-package name :nicknames nicknames :use use))))))
    148            (find-sym (symbol package)
    149              (find-symbol (string symbol) package))
    150150           (intern* (symbol package)
    151151             (intern (string symbol) package))
    152152           (remove-symbol (symbol package)
    153              (let ((sym (find-sym symbol package)))
     153             (let ((sym (find-symbol* symbol package)))
    154154               (when sym
    155155                 #-cormanlisp (unexport sym package)
     
    162162               :when removed :do
    163163               (loop :for p :in packages :do
    164                  (when (eq removed (find-sym sym p))
     164                 (when (eq removed (find-symbol* sym p))
    165165                   (unintern removed p)))))
    166166           (ensure-shadow (package symbols)
     
    169169             (dolist (used (reverse use))
    170170               (do-external-symbols (sym used)
    171                  (unless (eq sym (find-sym sym package))
     171                 (unless (eq sym (find-symbol* sym package))
    172172                   (remove-symbol sym package)))
    173173               (use-package used package)))
    174174           (ensure-fmakunbound (package symbols)
    175175             (loop :for name :in symbols
    176                :for sym = (find-sym name package)
     176               :for sym = (find-symbol* name package)
    177177               :when sym :do (fmakunbound sym)))
    178178           (ensure-export (package export)
     
    190190                 :for shadowing = (package-shadowing-symbols user) :do
    191191                 (loop :for new :in newly-exported-symbols
    192                    :for old = (find-sym new user)
     192                   :for old = (find-symbol* new user)
    193193                   :when (and old (not (member old shadowing)))
    194194                   :do (unintern old user)))
     
    231231           :export
    232232           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
    233             #:system-definition-pathname
     233            #:system-definition-pathname #:with-system-definitions
    234234            #:search-for-system-definition #:find-component ; miscellaneous
    235235            #:compile-system #:load-system #:test-system #:clear-system
     
    556556  (when pathname
    557557    (make-pathname :name nil :type nil :version nil
    558                    :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
     558                   :directory (merge-pathname-directory-components
     559                               '(:relative :back) (pathname-directory pathname))
    559560                   :defaults pathname)))
    560561
     
    787788  (make-pathname :directory '(:absolute)
    788789                 :name nil :type nil :version nil
    789                  :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:
    790792                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    791 
    792 (defun* find-symbol* (s p)
    793   (find-symbol (string s) p))
    794793
    795794(defun* probe-file* (p)
     
    801800    (pathname (unless (wild-pathname-p p)
    802801                #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
    803                       #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
     802                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
     803                                   `(ignore-errors (,it p)))
    804804                      '(ignore-errors (truename p)))))))
    805805
     
    865865(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
    866866(defparameter *wild-file*
    867   (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))
    868869(defparameter *wild-directory*
    869870  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
     
    11351136  ((name :accessor component-name :initarg :name :type string :documentation
    11361137         "Component name: designator for a string composed of portable pathname characters")
    1137    (version :accessor component-version :initarg :version) ;; :type (and string (satisfies parse-version)) -- not until we fix all systems that don't use it correctly!
     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!
     1141   (version :accessor component-version :initarg :version)
    11381142   (description :accessor component-description :initarg :description)
    11391143   (long-description :accessor component-long-description :initarg :long-description)
     
    14041408  (let ((system-name (coerce-name system)))
    14051409    (some #'(lambda (x) (funcall x system-name))
    1406           *system-definition-search-functions*)))
     1410          (cons 'find-system-if-being-defined *system-definition-search-functions*))))
    14071411
    14081412(defvar *central-registry* nil
     
    15151519  (find-system (coerce-name name) error-p))
    15161520
    1517 (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)
    15181538  ;; Tries to load system definition with canonical NAME from PATHNAME.
    1519   (let ((package (make-temporary-package)))
    1520     (unwind-protect
    1521          (handler-bind
    1522              ((error #'(lambda (condition)
    1523                          (error 'load-system-definition-error
    1524                                 :name name :pathname pathname
    1525                                 :condition condition))))
    1526            (let ((*package* package))
    1527              (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    1528                            pathname package)
    1529              (load pathname)))
    1530       (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)))))
    15311552
    15321553(defmethod find-system ((name string) &optional (error-p t))
    1533   (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    1534          (previous (cdr in-memory))
    1535          (previous (and (typep previous 'system) previous))
    1536          (previous-time (car in-memory))
    1537          (found (search-for-system-definition name))
    1538          (found-system (and (typep found 'system) found))
    1539          (pathname (or (and (typep found '(or pathname string)) (pathname found))
    1540                        (and found-system (system-source-file found-system))
    1541                        (and previous (system-source-file previous)))))
    1542     (setf pathname (resolve-symlinks* pathname))
    1543     (when (and pathname (not (absolute-pathname-p pathname)))
    1544       (setf pathname (ensure-pathname-absolute pathname))
    1545       (when found-system
    1546         (%set-system-source-file pathname found-system)))
    1547     (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
    1548                               (system-source-file previous) pathname)))
    1549       (%set-system-source-file pathname previous)
    1550       (setf previous-time nil))
    1551     (when (and found-system (not previous))
    1552       (register-system found-system))
    1553     (when (and pathname
    1554                (or (not previous-time)
    1555                    ;; don't reload if it's already been loaded,
    1556                    ;; or its filestamp is in the future which means some clock is skewed
    1557                    ;; and trying to load might cause an infinite loop.
    1558                    (< previous-time (safe-file-write-date pathname) (get-universal-time))))
    1559       (load-sysdef name pathname))
    1560     (let ((in-memory (system-registered-p name))) ; try again after loading from disk
    1561       (cond
    1562         (in-memory
    1563          (when pathname
    1564            (setf (car in-memory) (safe-file-write-date pathname)))
    1565          (cdr in-memory))
    1566         (error-p
    1567          (error 'missing-component :requires name))))))
     1554  (with-system-definitions ()
     1555    (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
     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)
     1577                     ;; don't reload if it's already been loaded,
     1578                     ;; or its filestamp is in the future which means some clock is skewed
     1579                     ;; and trying to load might cause an infinite loop.
     1580                     (< previous-time (safe-file-write-date pathname) (get-universal-time))))
     1581        (load-sysdef name pathname))
     1582      (let ((in-memory (system-registered-p name))) ; try again after loading from disk
     1583        (cond
     1584          (in-memory
     1585           (when pathname
     1586             (setf (car in-memory) (safe-file-write-date pathname)))
     1587           (cdr in-memory))
     1588          (error-p
     1589           (error 'missing-component :requires name)))))))
    15681590
    15691591(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
     
    16721694              (split-name-type filename)))
    16731695         (apply 'make-pathname :directory (cons relative path) :name name :type type
    1674                 ;; XCL 0.0.0.291 and ABCL 0.25 have a bug, whereby make-pathname merges directories like merge-pathnames when a :defaults is provided. Fixed in the latest XCL.
    16751696                (when defaults `(:defaults ,defaults))))))))
    16761697
     
    21262147        (apply *compile-op-compile-file-function* source-file :output-file output-file
    21272148               (compile-op-flags operation))
    2128       (when warnings-p
    2129         (case (operation-on-warnings operation)
    2130           (:warn (warn
    2131                   (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
    2132                   operation c))
    2133           (:error (error 'compile-warned :component c :operation operation))
    2134           (:ignore nil)))
     2149      (unless output
     2150        (error 'compile-error :component c :operation operation))
    21352151      (when failure-p
    21362152        (case (operation-on-failure operation)
     
    21402156          (:error (error 'compile-failed :component c :operation operation))
    21412157          (:ignore nil)))
    2142       (unless output
    2143         (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))))))
    21442165
    21452166(defmethod output-files ((operation compile-op) (c cl-source-file))
     
    22772298  nil)
    22782299
    2279 ;;; 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.
    22802301(defmethod component-depends-on ((o load-source-op) (c component))
    22812302  (declare (ignorable o))
    22822303  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
    2283     :for (op co) :in what-would-load-op-do
     2304    :for (op . co) :in what-would-load-op-do
    22842305    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
    22852306
     
    23812402                    &allow-other-keys)
    23822403  (declare (ignore force))
    2383   (let* ((op (apply 'make-instance operation-class
    2384                     :original-initargs args
    2385                     args))
    2386          (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
    2387          (system (etypecase system
    2388                    (system system)
    2389                    ((or string symbol) (find-system system)))))
    2390     (unless (version-satisfies system version)
    2391       (error 'missing-component-of-version :requires system :version version))
    2392     (let ((steps (traverse op system)))
    2393       (when (and (not (equal '("asdf") (component-find-path system)))
    2394                  (find-if #'(lambda (x) (equal '("asdf")
    2395                                                (component-find-path (cdr x))))
    2396                           steps)
    2397                  (upgrade-asdf))
    2398         ;; If we needed to upgrade ASDF to achieve our goal,
    2399         ;; then do it specially as the first thing, then
    2400         ;; invalidate all existing system
    2401         ;; retry the whole thing with the new OPERATE function,
    2402         ;; which on some implementations
    2403         ;; has a new symbol shadowing the current one.
    2404         (return-from operate
    2405           (apply (find-symbol* 'operate :asdf) operation-class system args)))
    2406       (perform-plan steps)
    2407       (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)))))
    24082429
    24092430(defun* oos (operation-class system &rest args &key force verbose version
     
    24802501        (default-directory))))
    24812502
    2482 (defmacro defsystem (name &body options)
    2483   (setf name (coerce-name name))
    2484   (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
    2485                             defsystem-depends-on &allow-other-keys)
    2486       options
    2487     (let ((component-options (remove-keys '(:class) options)))
    2488       `(progn
    2489          ;; system must be registered before we parse the body, otherwise
    2490          ;; we recur when trying to find an existing system of the same name
    2491          ;; to reuse options (e.g. pathname) from
    2492          ,@(loop :for system :in defsystem-depends-on
    2493              :collect `(load-system ',(coerce-name system)))
    2494          (let ((s (system-registered-p ',name)))
    2495            (cond ((and s (eq (type-of (cdr s)) ',class))
    2496                   (setf (car s) (get-universal-time)))
    2497                  (s
    2498                   (change-class (cdr s) ',class))
    2499                  (t
    2500                   (register-system (make-instance ',class :name ',name))))
    2501            (%set-system-source-file (load-pathname)
    2502                                     (cdr (system-registered-p ',name))))
    2503          (parse-component-form
    2504           nil (list*
    2505                :module (coerce-name ',name)
    2506                :pathname
    2507                ,(determine-system-pathname pathname pathname-arg-p)
    2508                ',component-options))))))
    2509 
    25102503(defun* class-for-type (parent type)
    25112504  (or (loop :for symbol :in (list
     
    25192512        :return class)
    25202513      (and (eq type :file)
    2521            (or (module-default-component-class parent)
     2514           (or (and parent (module-default-component-class parent))
    25222515               (find-class *default-component-class*)))
    25232516      (sysdef-error "don't recognize component type ~A" type)))
     
    26762669      ret)))
    26772670
     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
    26782705;;;; ---------------------------------------------------------------------------
    26792706;;;; run-shell-command
     
    28222849
    28232850(defparameter *os-features*
    2824   '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
     2851  '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    28252852    (:solaris :sunos)
    28262853    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
     
    28312858
    28322859(defparameter *architecture-features*
    2833   '((:amd64 :x86-64 :x86_64 :x8664-target)
     2860  '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386)
    28342861    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
    28352862    :hppa64 :hppa
     
    28442871(defun* lisp-version-string ()
    28452872  (let ((s (lisp-implementation-version)))
    2846     (declare (ignorable s))
    2847     #+allegro (format nil
    2848                       "~A~A~A~A"
    2849                       excl::*common-lisp-version-number*
    2850                       ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
    2851                       (if (eq excl:*current-case-mode*
    2852                               :case-sensitive-lower) "M" "A")
    2853                       ;; Note if not using International ACL
    2854                       ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
    2855                       (excl:ics-target-case
    2856                        (:-ics "8")
    2857                        (:+ics ""))
    2858                       (if (member :64bit *features*) "-64bit" ""))
    2859     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2860     #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    2861     #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    2862                       ccl::*openmcl-major-version*
    2863                       ccl::*openmcl-minor-version*
    2864                       (logand ccl::fasl-version #xFF))
    2865     #+cmu (substitute #\- #\/ s)
    2866     #+ecl (format nil "~A~@[-~A~]" s
    2867                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    2868                     (when (>= (length vcs-id) 8)
    2869                       (subseq vcs-id 0 8))))
    2870     #+gcl (subseq s (1+ (position #\space s)))
    2871     #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
    2872                (format nil "~D.~D" major minor))
    2873     #+lispworks (format nil "~A~@[~A~]" s
    2874                         (when (member :lispworks-64bit *features*) "-64bit"))
    2875     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
    2876     #+mcl (subseq s 8) ; strip the leading "Version "
    2877     #+(or cormanlisp sbcl scl) s
    2878     #-(or allegro armedbear clisp clozure cmu cormanlisp
    2879           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)))
    28802902
    28812903(defun* first-feature (features)
     
    29272949  #-asdf-unix #\;)
    29282950
     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
    29292959(defun* user-homedir ()
    2930   (truenamize (pathname-directory-pathname (user-homedir-pathname))))
     2960  (truenamize
     2961   (pathname-directory-pathname
     2962    #+mcl (current-user-homedir-pathname)
     2963    #-mcl (user-homedir-pathname))))
    29312964
    29322965(defun* try-directory-subpath (x sub &key type)
     
    29372970    (and ts (values sp ts))))
    29382971(defun* user-configuration-directories ()
    2939   (remove-if
    2940    #'null
    2941    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    2942      `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
    2943        ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
    2944            :for dir :in (split-string dirs :separator ":")
    2945            :collect (try dir "common-lisp/"))
    2946        #+asdf-windows
    2947         ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
    2948             ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    2949            ,(try (getenv "APPDATA") "common-lisp/config/"))
    2950        ,(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)))
    29512988(defun* system-configuration-directories ()
    29522989  (remove-if
    29532990   #'null
    2954    (append
    2955     #+asdf-windows
    2956     (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    2957       `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
    2958            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    2959         ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    2960     #+asdf-unix
    2961     (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
    29623000(defun* in-first-directory (dirs x)
    29633001  (loop :for dir :in dirs
     
    30313069                             #+clisp '(:circle t :if-does-not-exist :ignore)
    30323070                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
    3033                              #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
     3071                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
     3072                                      '(:resolve-symlinks nil))))))
    30343073
    30353074(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
     
    30773116     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
    30783117     #+asdf-windows
    3079      (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)
    30803123     '(:home ".cache" "common-lisp" :implementation))))
    30813124(defvar *system-cache*
     
    31763219                          :directory t :wilden nil))
    31773220            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
    3178             ((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))
    31793225            ((eql :default-directory) (default-directory))))
    31803226         (s (if (and wilden (not (pathnamep x)))
     
    33023348    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
    33033349                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
    3304     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    3305     #+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:"))) ()))
    33063353    ;; All-import, here is where we want user stuff to be:
    33073354    :inherit-configuration
     
    33903437                   (funcall collect (list trusrc t)))
    33913438                  (t
    3392                    (let* ((trudst (make-pathname
    3393                                    :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))
    33943442                          (wilddst (merge-pathnames* *wild-file* trudst)))
    33953443                     (funcall collect (list wilddst t))
     
    34753523
    34763524(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
    3477   (or output-file
     3525  (if (absolute-pathname-p output-file)
     3526      (apply 'compile-file-pathname (lispize-pathname input-file) keys)
    34783527      (apply-output-translations
    34793528       (apply 'compile-file-pathname
     
    34913540
    34923541(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
    3493   (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))
    34943543         (tmp-file (tmpize-pathname output-file))
    34953544         (status :error))
     
    35583607  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
    35593608         (mapped-files (if map-all-source-files *wild-file*
    3560                            (make-pathname :name :wild :version :wild :type fasl-type)))
     3609                           (make-pathname :type fasl-type :defaults *wild-file*)))
    35613610         (destination-directory
    35623611          (if centralize-lisp-binaries
     
    35923641
    35933642(defun* read-little-endian (s &optional (bytes 4))
    3594   (loop
    3595     :for i :from 0 :below bytes
     3643  (loop :for i :from 0 :below bytes
    35963644    :sum (ash (read-byte s) (* 8 i))))
    35973645
     
    36603708    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    36613709    "_sgbak" "autom4te.cache" "cover_db" "_build"
    3662     "debian")) ;; debian often build stuff under the debian directory... BAD.
     3710    "debian")) ;; debian often builds stuff under the debian directory... BAD.
    36633711
    36643712(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     
    36873735(defun subdirectories (directory)
    36883736  (let* ((directory (ensure-directory-pathname directory))
    3689          #-(or cormanlisp genera xcl)
     3737         #-(or abcl cormanlisp genera xcl)
    36903738         (wild (merge-pathnames*
    36913739                #-(or abcl allegro cmu lispworks scl xcl)
     
    36943742                directory))
    36953743         (dirs
    3696           #-(or cormanlisp genera xcl)
     3744          #-(or abcl cormanlisp genera xcl)
    36973745          (ignore-errors
    36983746            (directory* wild . #.(or #+clozure '(:directories t :files nil)
    36993747                                     #+mcl '(:directories t))))
     3748          #+(or abcl xcl) (system:list-directory directory)
    37003749          #+cormanlisp (cl::directory-subdirs directory)
    3701           #+genera (fs:directory-list directory)
    3702           #+xcl (system:list-directory directory))
     3750          #+genera (fs:directory-list directory))
    37033751         #+(or abcl allegro cmu genera lispworks scl xcl)
    37043752         (dirs (loop :for x :in dirs
     
    37763824      :for pos = (position *inter-directory-separator* string :start start) :do
    37773825      (let ((s (subseq string start (or pos end))))
    3778         (cond
    3779          ((equal "" s) ; empty element: inherit
    3780           (when inherit
    3781             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    3782                    string))
    3783           (setf inherit t)
    3784           (push ':inherit-configuration directives))
    3785          ((ends-with s "//")
    3786           (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
    3787          (t
    3788           (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))))
    37893841        (cond
    37903842          (pos
     
    38183870    #+cmu (:tree #p"modules:")))
    38193871(defun* default-source-registry ()
    3820   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     3872  (flet ((try (x sub) (try-directory-subpath x sub)))
    38213873    `(:source-registry
    3822       #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
     3874      #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
    38233875      (:directory ,(default-directory))
    3824       ,@(let*
    3825          #+asdf-unix
    3826          ((datahome
    3827            (or (getenv "XDG_DATA_HOME")
    3828                (try (user-homedir) ".local/share/")))
    3829           (datadirs
    3830            (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
    3831           (dirs (cons datahome (split-string datadirs :separator ":"))))
    3832          #+asdf-windows
    3833          ((datahome (getenv "APPDATA"))
    3834           (datadir
    3835            #+lispworks (sys:get-folder-path :local-appdata)
    3836            #-lispworks (try (getenv "ALLUSERSPROFILE")
    3837                             "Application Data"))
    3838           (dirs (list datahome datadir)))
    3839          #-(or asdf-unix asdf-windows)
    3840          ((dirs ()))
    3841          (loop :for dir :in dirs
    3842            :collect `(:directory ,(try dir "common-lisp/systems/"))
    3843            :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/")))
    38443893      :inherit-configuration)))
    38453894(defun* user-source-registry ()
     
    39333982  (dolist (entry (flatten-source-registry parameter))
    39343983    (destructuring-bind (directory &key recurse exclude) entry
    3935       (let* ((h (make-hash-table :test 'equal)))
     3984      (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
    39363985        (register-asd-directory
    39373986         directory :recurse recurse :exclude exclude :collect
Note: See TracChangeset for help on using the changeset viewer.