Changeset 15743 for release


Ignore:
Timestamp:
Feb 21, 2013, 12:11:01 AM (6 years ago)
Author:
rme
Message:

Merge ASDF 2.30 from trunk.

Location:
release/1.9/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/1.9/source

  • release/1.9/source/tools/asdf.lisp

    r15737 r15743  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.29: Another System Definition Facility.
     2;;; This is ASDF 2.30: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    5555  (setf ext:*gc-verbose* nil))
    5656
    57 #+(or abcl clisp cmu ecl xcl)
     57#+(or abcl clisp clozure cmu ecl xcl)
    5858(eval-when (:load-toplevel :compile-toplevel :execute)
    5959  (unless (member :asdf3 *features*)
     
    7272           (away (format nil "~A-~A" :asdf existing-version)))
    7373      (when (and existing-version (< existing-version-number
    74                                      #+abcl 2.25 #+clisp 2.27 #+cmu 2.018 #+ecl 2.21 #+xcl 2.27))
     74                                     #+abcl 2.25 #+clisp 2.27 #+clozure 2.27
     75                                     #+cmu 2.018 #+ecl 2.21 #+xcl 2.27))
    7576        (rename-package :asdf away)
    7677        (when *load-verbose*
     
    992993   #:match-condition-p #:match-any-condition-p ;; conditions
    993994   #:call-with-muffled-conditions #:with-muffled-conditions
    994    #:load-string #:load-stream
    995995   #:lexicographic< #:lexicographic<=
    996996   #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
     
    13631363
    13641364(with-upgradability ()
    1365   (defvar *uninteresting-conditions* nil
    1366     "Uninteresting conditions, as per MATCH-CONDITION-P")
    1367 
    13681365  (defparameter +simple-condition-format-control-slot+
    13691366    #+abcl 'system::format-control
     
    14021399      (funcall thunk)))
    14031400
    1404   (defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
    1405     `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions)))
     1401  (defmacro with-muffled-conditions ((conditions) &body body)
     1402    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
    14061403
    14071404
     
    15971594  (defun hostname ()
    15981595    ;; Note: untested on RMCL
    1599     #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
     1596    #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
    16001597    #+cormanlisp "localhost" ;; is there a better way? Does it matter?
    16011598    #+allegro (symbol-call :excl.osi :gethostname)
     
    16581655;;;; http://www.wotsit.org/list.asp?fc=13
    16591656
    1660 (with-upgradability ()
    1661   #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
    1662   (progn
    1663     (defparameter *link-initial-dword* 76)
    1664     (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
    1665 
    1666     (defun read-null-terminated-string (s)
    1667       (with-output-to-string (out)
    1668         (loop :for code = (read-byte s)
    1669               :until (zerop code)
    1670               :do (write-char (code-char code) out))))
    1671 
    1672     (defun read-little-endian (s &optional (bytes 4))
    1673       (loop :for i :from 0 :below bytes
    1674             :sum (ash (read-byte s) (* 8 i))))
    1675 
    1676     (defun parse-file-location-info (s)
    1677       (let ((start (file-position s))
    1678             (total-length (read-little-endian s))
    1679             (end-of-header (read-little-endian s))
    1680             (fli-flags (read-little-endian s))
    1681             (local-volume-offset (read-little-endian s))
    1682             (local-offset (read-little-endian s))
    1683             (network-volume-offset (read-little-endian s))
    1684             (remaining-offset (read-little-endian s)))
    1685         (declare (ignore total-length end-of-header local-volume-offset))
    1686         (unless (zerop fli-flags)
    1687           (cond
    1688             ((logbitp 0 fli-flags)
    1689              (file-position s (+ start local-offset)))
    1690             ((logbitp 1 fli-flags)
    1691              (file-position s (+ start
    1692                                  network-volume-offset
    1693                                  #x14))))
    1694           (strcat (read-null-terminated-string s)
    1695                   (progn
    1696                     (file-position s (+ start remaining-offset))
    1697                     (read-null-terminated-string s))))))
    1698 
    1699     (defun parse-windows-shortcut (pathname)
    1700       (with-open-file (s pathname :element-type '(unsigned-byte 8))
    1701         (handler-case
    1702             (when (and (= (read-little-endian s) *link-initial-dword*)
    1703                        (let ((header (make-array (length *link-guid*))))
    1704                          (read-sequence header s)
    1705                          (equalp header *link-guid*)))
    1706               (let ((flags (read-little-endian s)))
    1707                 (file-position s 76)        ;skip rest of header
    1708                 (when (logbitp 0 flags)
    1709                   ;; skip shell item id list
    1710                   (let ((length (read-little-endian s 2)))
    1711                     (file-position s (+ length (file-position s)))))
    1712                 (cond
    1713                   ((logbitp 1 flags)
    1714                    (parse-file-location-info s))
    1715                   (t
    1716                    (when (logbitp 2 flags)
    1717                      ;; skip description string
    1718                      (let ((length (read-little-endian s 2)))
    1719                        (file-position s (+ length (file-position s)))))
    1720                    (when (logbitp 3 flags)
    1721                      ;; finally, our pathname
    1722                      (let* ((length (read-little-endian s 2))
    1723                             (buffer (make-array length)))
    1724                        (read-sequence buffer s)
    1725                        (map 'string #'code-char buffer)))))))
    1726           (end-of-file (c)
    1727             (declare (ignore c))
    1728             nil))))))
     1657#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
     1658(with-upgradability ()
     1659  (defparameter *link-initial-dword* 76)
     1660  (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
     1661
     1662  (defun read-null-terminated-string (s)
     1663    (with-output-to-string (out)
     1664      (loop :for code = (read-byte s)
     1665            :until (zerop code)
     1666            :do (write-char (code-char code) out))))
     1667
     1668  (defun read-little-endian (s &optional (bytes 4))
     1669    (loop :for i :from 0 :below bytes
     1670          :sum (ash (read-byte s) (* 8 i))))
     1671
     1672  (defun parse-file-location-info (s)
     1673    (let ((start (file-position s))
     1674          (total-length (read-little-endian s))
     1675          (end-of-header (read-little-endian s))
     1676          (fli-flags (read-little-endian s))
     1677          (local-volume-offset (read-little-endian s))
     1678          (local-offset (read-little-endian s))
     1679          (network-volume-offset (read-little-endian s))
     1680          (remaining-offset (read-little-endian s)))
     1681      (declare (ignore total-length end-of-header local-volume-offset))
     1682      (unless (zerop fli-flags)
     1683        (cond
     1684          ((logbitp 0 fli-flags)
     1685           (file-position s (+ start local-offset)))
     1686          ((logbitp 1 fli-flags)
     1687           (file-position s (+ start
     1688                               network-volume-offset
     1689                               #x14))))
     1690        (strcat (read-null-terminated-string s)
     1691                (progn
     1692                  (file-position s (+ start remaining-offset))
     1693                  (read-null-terminated-string s))))))
     1694
     1695  (defun parse-windows-shortcut (pathname)
     1696    (with-open-file (s pathname :element-type '(unsigned-byte 8))
     1697      (handler-case
     1698          (when (and (= (read-little-endian s) *link-initial-dword*)
     1699                     (let ((header (make-array (length *link-guid*))))
     1700                       (read-sequence header s)
     1701                       (equalp header *link-guid*)))
     1702            (let ((flags (read-little-endian s)))
     1703              (file-position s 76)        ;skip rest of header
     1704              (when (logbitp 0 flags)
     1705                ;; skip shell item id list
     1706                (let ((length (read-little-endian s 2)))
     1707                  (file-position s (+ length (file-position s)))))
     1708              (cond
     1709                ((logbitp 1 flags)
     1710                 (parse-file-location-info s))
     1711                (t
     1712                 (when (logbitp 2 flags)
     1713                   ;; skip description string
     1714                   (let ((length (read-little-endian s 2)))
     1715                     (file-position s (+ length (file-position s)))))
     1716                 (when (logbitp 3 flags)
     1717                   ;; finally, our pathname
     1718                   (let* ((length (read-little-endian s 2))
     1719                          (buffer (make-array length)))
     1720                     (read-sequence buffer s)
     1721                     (map 'string #'code-char buffer)))))))
     1722        (end-of-file (c)
     1723          (declare (ignore c))
     1724          nil)))))
    17291725
    17301726
     
    24852481        (string (probe-file* (parse-namestring p) :truename truename))
    24862482        (pathname
    2487          (handler-case
    2488              (or
    2489               #+allegro
    2490               (probe-file p :follow-symlinks truename)
    2491               #-(or allegro clisp gcl2.6)
    2492               (if truename
    2493                   (probe-file p)
    2494                   (and (not (wild-pathname-p p))
     2483         (and (not (wild-pathname-p p))
     2484              (handler-case
     2485                  (or
     2486                   #+allegro
     2487                   (probe-file p :follow-symlinks truename)
     2488                   #-(or allegro clisp gcl2.6)
     2489                   (if truename
     2490                       (probe-file p)
    24952491                       (ignore-errors
    24962492                        (let ((pp (translate-logical-pathname p)))
    2497                           #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
    2498                           #+(and lispworks unix) (system:get-file-stat pp)
    2499                           #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
    2500                           #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)))
    2501                        p))
    2502               #+(or clisp gcl2.6)
    2503               #.(flet ((probe (probe)
    2504                          `(let ((foundtrue ,probe))
    2505                             (cond
    2506                               (truename foundtrue)
    2507                               (foundtrue p)))))
    2508                   #+gcl2.6
    2509                   (probe '(or (probe-file p)
    2510                            (and (directory-pathname-p p)
    2511                             (ignore-errors
    2512                              (ensure-directory-pathname
    2513                               (truename* (subpathname
    2514                                           (ensure-directory-pathname p) ".")))))))
    2515                   #+clisp
    2516                   (let* ((fs (find-symbol* '#:file-stat :posix nil))
    2517                          (pp (find-symbol* '#:probe-pathname :ext nil))
    2518                          (resolve (if pp
    2519                                       `(ignore-errors (,pp p))
    2520                                       '(or (truename* p)
    2521                                         (truename* (ignore-errors (ensure-directory-pathname p)))))))
    2522                     (if fs
    2523                         `(if truename
    2524                              ,resolve
    2525                              (and (ignore-errors (,fs p)) p))
    2526                         (probe resolve)))))
    2527            (file-error () nil))))))
     2493                          (and
     2494                           #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
     2495                           #+(and lispworks unix) (system:get-file-stat pp)
     2496                           #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
     2497                           #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
     2498                           p))))
     2499                   #+(or clisp gcl2.6)
     2500                   #.(flet ((probe (probe)
     2501                              `(let ((foundtrue ,probe))
     2502                                 (cond
     2503                                   (truename foundtrue)
     2504                                   (foundtrue p)))))
     2505                       #+gcl2.6
     2506                       (probe '(or (probe-file p)
     2507                                (and (directory-pathname-p p)
     2508                                 (ignore-errors
     2509                                  (ensure-directory-pathname
     2510                                   (truename* (subpathname
     2511                                               (ensure-directory-pathname p) ".")))))))
     2512                       #+clisp
     2513                       (let* ((fs (find-symbol* '#:file-stat :posix nil))
     2514                              (pp (find-symbol* '#:probe-pathname :ext nil))
     2515                              (resolve (if pp
     2516                                           `(ignore-errors (,pp p))
     2517                                           '(or (truename* p)
     2518                                             (truename* (ignore-errors (ensure-directory-pathname p)))))))
     2519                         (if fs
     2520                             `(if truename
     2521                                  ,resolve
     2522                                  (and (ignore-errors (,fs p)) p))
     2523                             (probe resolve)))))
     2524                (file-error () nil)))))))
    25282525
    25292526  (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
     
    28592856  (defun ensure-all-directories-exist (pathnames)
    28602857    (dolist (pathname pathnames)
    2861       (ensure-directories-exist (translate-logical-pathname pathname))))
     2858      (when pathname
     2859        (ensure-directories-exist (translate-logical-pathname pathname)))))
    28622860
    28632861  (defun rename-file-overwriting-target (source target)
     
    28882886   #:finish-outputs #:format! #:safe-format!
    28892887   #:copy-stream-to-stream #:concatenate-files
    2890    #:copy-stream-to-stream-line-by-line
    28912888   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
    28922889   #:slurp-stream-forms #:slurp-stream-form
     
    33363333   #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
    33373334   #:*lisp-interaction*
    3338    #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition
     3335   #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
    33393336   #:call-with-fatal-condition-handler #:with-fatal-condition-handler
    33403337   #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
     
    33443341   #:register-image-restore-hook #:register-image-dump-hook
    33453342   #:call-image-restore-hook #:call-image-dump-hook
    3346    #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image
     3343   #:restore-image #:dump-image #:create-image
    33473344))
    33483345(in-package :asdf/image)
     
    34373434      (ccl:print-call-history :count count :start-frame-number 1)
    34383435      (finish-output stream))
    3439     #+(or cmucl scl)
     3436    #+(or cmu scl)
    34403437    (let ((debug:*debug-print-level* *print-level*)
    34413438          (debug:*debug-print-length* *print-length*))
     
    42354232      (symbol (reify-symbol sexp))
    42364233      ((or number character simple-string pathname) sexp)
    4237       (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))))
     4234      (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
     4235      (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
     4236   
    42384237  (defun unreify-simple-sexp (sexp)
    42394238    (etypecase sexp
    42404239      ((or symbol number character simple-string pathname) sexp)
    42414240      (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
    4242       ((simple-vector 2) (unreify-symbol sexp))))
     4241      ((simple-vector 2) (unreify-symbol sexp))
     4242      ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
    42434243
    42444244  #+clozure
     
    42574257                                 :source (unreify-source-note source)))))
    42584258    (defun reify-function-name (function-name)
    4259       (reify-simple-sexp
    4260        (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%))
    4261          `(setf ,setfed)
    4262          function-name)))
     4259      (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%))
     4260              `(setf ,setfed)
     4261              function-name))
    42634262    (defun unreify-function-name (function-name)
    4264       (let ((name (unreify-simple-sexp function-name)))
    4265         (if (and (consp name) (eq (first name) 'setf))
    4266             (let ((setfed (second name)))
    4267               (gethash setfed ccl::%setf-function-names%))
    4268             name)))
     4263      (if (and (consp function-name) (eq (first function-name) 'setf))
     4264          (let ((setfed (second function-name)))
     4265            (gethash setfed ccl::%setf-function-names%))
     4266        function-name))
    42694267    (defun reify-deferred-warning (deferred-warning)
    42704268      (with-accessors ((warning-type ccl::compiler-warning-warning-type)
     
    42754273              :source-note (reify-source-note source-note)
    42764274              :args (destructuring-bind (fun . formals) args
    4277                       (cons (reify-function-name fun) (reify-simple-sexp formals))))))
     4275                      (cons (reify-function-name fun) formals)))))
    42784276    (defun unreify-deferred-warning (reified-deferred-warning)
    42794277      (destructuring-bind (&key warning-type function-name source-note args)
     
    42854283                        :warning-type warning-type
    42864284                        :args (destructuring-bind (fun . formals) args
    4287                                 (cons (unreify-function-name fun) (unreify-simple-sexp formals)))))))
     4285                                (cons (unreify-function-name fun) formals))))))
    42884286  #+(or cmu scl)
    42894287  (defun reify-undefined-warning (warning)
     
    43314329WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
    43324330    #+allegro
    4333     (reify-simple-sexp
    4334      (list :functions-defined excl::.functions-defined.
    4335            :functions-called excl::.functions-called.))
     4331    (list :functions-defined excl::.functions-defined.
     4332          :functions-called excl::.functions-called.)
    43364333    #+clozure
    43374334    (mapcar 'reify-deferred-warning
     
    43754372    #+allegro
    43764373    (destructuring-bind (&key functions-defined functions-called)
    4377         (unreify-simple-sexp reified-deferred-warnings)
     4374                        reified-deferred-warnings
    43784375      (setf excl::.functions-defined.
    43794376            (append functions-defined excl::.functions-defined.)
     
    51195116         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    51205117         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    5121          (asdf-version "2.29")
     5118         (asdf-version "2.30")
    51225119         (existing-version (asdf-version)))
    51235120    (setf *asdf-version* asdf-version)
     
    56805677   #:find-system-if-being-defined #:*systems-being-defined*
    56815678   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
    5682    #:system-find-preloaded-system #:register-preloaded-system #:*preloaded-systems*
     5679   #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
    56835680   #:clear-defined-systems #:*defined-systems*
    56845681   ;; defined in source-registry, but specially mentioned here:
     
    57635760      (when asdf
    57645761        (setf (component-version asdf) *asdf-version*)
     5762        (setf (builtin-system-p asdf) t)
    57655763        (register-system asdf)))
    57665764    (values))
     
    58025800                      '(sysdef-central-registry-search
    58035801                        sysdef-source-registry-search
    5804                         sysdef-find-preloaded-systems)))))
     5802                        sysdef-preloaded-system-search)))))
    58055803  (cleanup-system-definition-search-functions)
    58065804
     
    59185916    `(call-with-system-definitions #'(lambda () ,@body)))
    59195917
    5920   (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))))
     5918  (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
    59215919    ;; Tries to load system definition with canonical NAME from PATHNAME.
    59225920    (with-system-definitions ()
    59235921      (with-standard-io-syntax
    59245922        (let ((*package* (find-package :asdf-user))
     5923              ;; Note that our backward-compatible *readtable* is
     5924              ;; a global readtable that gets globally side-effected. Ouch.
     5925              ;; Same for the *print-pprint-dispatch* table.
     5926              ;; We should do something about that for ASDF3 if possible, or else ASDF4.
     5927              (*readtable* readtable)
     5928              (*print-pprint-dispatch* print-pprint-dispatch)
    59255929              (*print-readably* nil)
    59265930              (*default-pathname-defaults*
     
    60036007  (defvar *preloaded-systems* (make-hash-table :test 'equal))
    60046008
    6005   (defun sysdef-find-preloaded-systems (requested)
     6009  (defun sysdef-preloaded-system-search (requested)
    60066010    (let ((name (coerce-name requested)))
    60076011      (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
     
    67846788   #:node-for #:needed-in-image-p
    67856789   #:action-index #:action-planned-p #:action-valid-p
    6786    #:plan-record-dependency #:visiting-action-p
     6790   #:plan-record-dependency
    67876791   #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
    67886792   #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
     
    72197223  (:export
    72207224   #:operate #:oos
    7221    #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
     7225   #:*systems-being-operated*
    72227226   #:build-system
    72237227   #:load-system #:load-systems #:compile-system #:test-system #:require-system
    72247228   #:*load-system-operation* #:module-provide-asdf
    7225    #:component-loaded-p #:already-loaded-systems
    7226    #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*))
     7229   #:component-loaded-p #:already-loaded-systems))
    72277230(in-package :asdf/operate)
    72287231
     
    73757378        (dolist (s l) (find-system s nil)))))
    73767379
    7377   (pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*))
     7380  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
    73787381
    73797382
     
    77017704  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
    77027705  (:export
    7703    #:*source-registry* #:*source-registry-parameter* #:*default-source-registries*
     7706   #:*source-registry-parameter* #:*default-source-registries*
    77047707   #:invalid-source-registry
    7705    #:source-registry #:source-registry-initialized-p
     7708   #:source-registry-initialized-p
    77067709   #:initialize-source-registry #:clear-source-registry #:*source-registry*
    7707    #:disable-source-registry #:ensure-source-registry #:*source-registry-parameter*
     7710   #:ensure-source-registry #:*source-registry-parameter*
    77087711   #:*default-source-registry-exclusions* #:*source-registry-exclusions*
    77097712   #:*wild-asd* #:directory-asd-files #:register-asd-directory
     
    87968799   #:monolithic-load-concatenated-source-op
    87978800   #:monolithic-compile-concatenated-source-op
    8798    #:monolithic-load-compiled-concatenated-source-op
    8799    #:component-concatenated-source-file
    8800    #:concatenated-source-file))
     8801   #:monolithic-load-compiled-concatenated-source-op))
    88018802(in-package :asdf/concatenate-source)
    88028803
     
    90959096   #:file-component #:source-file #:c-source-file #:java-source-file
    90969097   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
    9097    #:static-file #:doc-file #:html-file :text-file
     9098   #:static-file #:doc-file #:html-file
    90989099   #:source-file-type
    90999100
     
    91249125   #:system-relative-pathname
    91259126   #:system-homepage
     9127   #:system-mailto
    91269128   #:system-bug-tracker
    9127    #:system-developers-email
    91289129   #:system-long-name
    91299130   #:system-source-control
Note: See TracChangeset for help on using the changeset viewer.