Changeset 16141


Ignore:
Timestamp:
Jul 25, 2014, 10:54:49 PM (7 years ago)
Author:
rme
Message:

ASDF 3.1.3.

File:
1 edited

Legend:

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

    r16074 r16141  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
    2 ;;; This is ASDF 3.1.2: Another System Definition Facility.
     2;;; This is ASDF 3.1.3: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    403403                       (t (push name intern)))))))
    404404        (labels ((sort-names (names)
    405                    (sort names #'string<))
     405                   (sort (copy-list names) #'string<))
    406406                 (table-keys (table)
    407407                   (loop :for k :being :the :hash-keys :of table :collect k))
     
    846846(uiop/package:define-package :uiop/common-lisp
    847847  (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
    848   (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package)
    849   (:reexport :common-lisp)
     848  (:use :uiop/package)
     849  (:use-reexport #-genera :common-lisp #+genera :future-common-lisp)
    850850  (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf)
    851851  #+allegro (:intern #:*acl-warn-save*)
     
    856856   #:make-broadcast-stream #:file-namestring)
    857857  #+genera (:shadowing-import-from :scl #:boolean)
    858   #+genera (:export #:boolean #:ensure-directories-exist)
     858  #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence)
    859859  #+mcl (:shadow #:user-homedir-pathname))
    860860(in-package :uiop/common-lisp)
     
    936936#+genera
    937937(eval-when (:load-toplevel :compile-toplevel :execute)
     938  (unless (fboundp 'lambda)
     939    (defmacro lambda (&whole form &rest bvl-decls-and-body)
     940      (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1))
     941      `#',(cons 'lisp::lambda (cdr form))))
    938942  (unless (fboundp 'ensure-directories-exist)
    939943    (defun ensure-directories-exist (path)
    940       (fs:create-directories-recursively (pathname path)))))
     944      (fs:create-directories-recursively (pathname path))))
     945  (unless (fboundp 'read-sequence)
     946    (defun read-sequence (sequence stream &key (start 0) end)
     947      (scl:send stream :string-in nil sequence start end)))
     948  (unless (fboundp 'write-sequence)
     949    (defun write-sequence (sequence stream &key (start 0) end)
     950      (scl:send stream :string-out sequence start end)
     951      sequence)))
    941952
    942953#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
     
    12141225;;; Characters
    12151226(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
    1216   (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
     1227  (defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char)))
    12171228  #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
    12181229  (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
     
    13911402      (function fun)
    13921403      ((or boolean keyword character number pathname) (constantly fun))
    1393       (hash-table (lambda (x) (gethash x fun)))
     1404      (hash-table #'(lambda (x) (gethash x fun)))
    13941405      (symbol (fdefinition fun))
    13951406      (cons (if (eq 'lambda (car fun))
     
    17511762    "The operating system of the current host"
    17521763    (first-feature
    1753      '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
     1764     '(:cygwin
     1765       (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
    17541766       (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
    17551767       (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
    1756        (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
     1768       (:solaris :solaris :sunos)
     1769       (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly)
     1770       :unix
    17571771       :genera)))
    17581772
     
    25532567when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
    25542568    (let ((sub (when maybe-subpath (pathname maybe-subpath)))
    2555           (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
     2569          (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
    25562570      (or (and base (subpathp sub base)) sub)))
    25572571
     
    32983312    #+cormanlisp (win32:delete-directory directory-pathname)
    32993313    #+ecl (si:rmdir directory-pathname)
     3314    #+genera (fs:delete-directory directory-pathname)
    33003315    #+lispworks (lw:delete-directory directory-pathname)
    33013316    #+mkcl (mkcl:rmdir directory-pathname)
     
    33043319               `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
    33053320    #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
    3306     #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl)
     3321    #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
    33073322    (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
    33083323
     
    33383353              'delete-filesystem-tree directory-pathname))
    33393354         (:ignore nil)))
    3340       #-(or allegro cmu clozure sbcl scl)
     3355      #-(or allegro cmu clozure genera sbcl scl)
    33413356      ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
    33423357       ;; except on implementations where we can prevent DIRECTORY from following symlinks;
     
    33483363                              directory-pathname :if-does-not-exist if-does-not-exist)
    33493364       #+clozure (ccl:delete-directory directory-pathname)
    3350        #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
     3365       #+genera (fs:delete-directory directory-pathname :confirm nil)
    33513366       #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
    33523367                  `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
     
    39964011           (afterf (gensym "AFTER")))
    39974012      `(flet (,@(when before
    3998                   `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before)))
     4013                  `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
     4014                       ,@(when after `((declare (ignorable ,pathname))))
     4015                       ,@before)))
    39994016              ,@(when after
    40004017                  (assert pathnamep)
     
    41214138    #+ecl (si:quit code)
    41224139    #+gcl (system:quit code)
    4123     #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
     4140    #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
    41244141    #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
    41254142    #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
     
    41454162    #+abcl
    41464163    (loop :for i :from 0
    4147           :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
    4148             (safe-format! stream "~&~D: ~A~%" i frame))
     4164          :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
     4165            (safe-format! stream "~&~D: ~A~%" i frame))
    41494166    #+allegro
    41504167    (let ((*terminal-io* stream)
     
    41704187    #+(or ecl mkcl)
    41714188    (let* ((top (si:ihs-top))
    4172            (repeats (if count (min top count) top))
    4173            (backtrace (loop :for ihs :from 0 :below top
     4189           (repeats (if count (min top count) top))
     4190           (backtrace (loop :for ihs :from 0 :below top
    41744191                            :collect (list (si::ihs-fun ihs)
    41754192                                           (si::ihs-env ihs)))))
    41764193      (loop :for i :from 0 :below repeats
    4177             :for frame :in (nreverse backtrace) :do
    4178               (safe-format! stream "~&~D: ~S~%" i frame)))
     4194            :for frame :in (nreverse backtrace) :do
     4195              (safe-format! stream "~&~D: ~S~%" i frame)))
    41794196    #+gcl
    41804197    (let ((*debug-io* stream))
    41814198      (ignore-errors
    41824199       (with-safe-io-syntax ()
    4183         (if condition
    4184              (conditions::condition-backtrace condition)
    4185              (system::simple-backtrace)))))
     4200        (if condition
     4201             (conditions::condition-backtrace condition)
     4202             (system::simple-backtrace)))))
    41864203    #+lispworks
    41874204    (let ((dbg::*debugger-stack*
     
    41974214    #+xcl
    41984215    (loop :for i :from 0 :below (or count most-positive-fixnum)
    4199           :for frame :in (extensions:backtrace-as-list) :do
    4200             (safe-format! stream "~&~D: ~S~%" i frame)))
     4216          :for frame :in (extensions:backtrace-as-list) :do
     4217            (safe-format! stream "~&~D: ~S~%" i frame)))
    42014218
    42024219  (defun print-backtrace (&rest keys &key stream count condition)
     
    42984315      #-(or sbcl allegro)
    42994316      (unless (eq *image-dumped-p* :executable)
    4300         ;; LispWorks command-line processing isn't transparent to the user
    4301         ;; unless you create a standalone executable; in that case,
    4302         ;; we rely on cl-launch or some other script to set the arguments for us.
    4303         #+lispworks (return *command-line-arguments*)
    4304         ;; On other implementations, on non-standalone executables,
    4305         ;; we trust cl-launch or whichever script starts the program
    4306         ;; to use -- as a delimiter between implementation arguments and user arguments.
    4307         #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
     4317        ;; LispWorks command-line processing isn't transparent to the user
     4318        ;; unless you create a standalone executable; in that case,
     4319        ;; we rely on cl-launch or some other script to set the arguments for us.
     4320        #+lispworks (return *command-line-arguments*)
     4321        ;; On other implementations, on non-standalone executables,
     4322        ;; we trust cl-launch or whichever script starts the program
     4323        ;; to use -- as a delimiter between implementation arguments and user arguments.
     4324        #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
    43084325      (rest arguments)))
    43094326
     
    43404357Then, comes the restore process itself:
    43414358First, call each function in the RESTORE-HOOK,
    4342 in the order they were registered with REGISTER-RESTORE-HOOK.
     4359in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
    43434360Second, evaluate the prelude, which is often Lisp text that is read,
    43444361as per EVAL-INPUT.
     
    43854402                                #+clozure prepend-symbols #+clozure (purify t)
    43864403                                #+sbcl compression
    4387                                 #+(and sbcl windows) application-type)
     4404                                #+(and sbcl os-windows) application-type)
    43884405    "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
    43894406
     
    44594476              ;;--- only save runtime-options for standalone executables
    44604477              (when executable (list :toplevel #'restore-image :save-runtime-options t))
    4461               #+(and sbcl windows) ;; passing :application-type :gui will disable the console window.
     4478              #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
    44624479              ;; the default is :console - only works with SBCL 1.1.15 or later.
    44634480              (when application-type (list :application-type application-type)))))
     
    52965313    (%wait-process-result
    52975314     (apply '%run-program (%normalize-system-command command) :wait t keys))
    5298     #+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl)
     5315    #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
    52995316    (let ((%command (%redirected-system-command command input output error-output directory)))
    53005317      #+(and lispworks os-windows)
     
    53135330                (ext:system %command))
    53145331        #+gcl (system:system %command)
     5332        #+genera (error "~S not supported on Genera, cannot run ~S"
     5333                        '%system %command)
    53155334        #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
    53165335        #+mkcl (mkcl:system %command)
     
    63436362be applied to the results to yield a configuration form.  Current
    63446363values of TAG include :source-registry and :output-translations."
    6345     (let ((files (sort (ignore-errors
     6364    (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
    63466365                        (remove-if
    63476366                         'hidden-pathname-p
     
    65696588   :uiop/configuration :uiop/backward-driver))
    65706589
    6571 #+mkcl (provide :uiop)
     6590;; Provide both lowercase and uppercase, to satisfy more people.
     6591(provide "uiop") (provide "UIOP")
    65726592;;;; -------------------------------------------------------------------------
    65736593;;;; Handle upgrade as forward- and backward-compatibly as possible
     
    66396659         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    66406660         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    6641          (asdf-version "3.1.2")
     6661         (asdf-version "3.1.3")
    66426662         (existing-version (asdf-version)))
    66436663    (setf *asdf-version* asdf-version)
     
    66516671(when-upgrading ()
    66526672  (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
    6653           ;; NB: it's too late to do anything about functions in UIOP!
    6654           ;; If you introduce some critically incompatibility there, you must change name.
     6673          ;; NB: it's too late to do anything about functions in UIOP!
     6674          ;; If you introduce some critically incompatibility there, you must change name.
    66556675          '(#:component-relative-pathname #:component-parent-pathname ;; component
    66566676            #:source-file-type
    66576677            #:find-system #:system-source-file #:system-relative-pathname ;; system
    6658             #:find-component ;; find-component
    6659             #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
    6660             #:component-depends-on #:operation-done-p #:component-depends-on
    6661             #:traverse ;; backward-interface
     6678            #:find-component ;; find-component
     6679            #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
     6680            #:component-depends-on #:operation-done-p #:component-depends-on
     6681            #:traverse ;; backward-interface
    66626682            #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan
    6663             #:operate  ;; operate
    6664             #:parse-component-form ;; defsystem
    6665             #:apply-output-translations ;; output-translations
    6666             #:process-output-translations-directive
    6667             #:inherit-source-registry #:process-source-registry ;; source-registry
    6668             #:process-source-registry-directive
    6669             #:trivial-system-p)) ;; bundle
    6670         (redefined-classes
     6683            #:operate  ;; operate
     6684            #:parse-component-form ;; defsystem
     6685            #:apply-output-translations ;; output-translations
     6686            #:process-output-translations-directive
     6687            #:inherit-source-registry #:process-source-registry ;; source-registry
     6688            #:process-source-registry-directive
     6689            #:trivial-system-p)) ;; bundle
     6690        (redefined-classes
    66716691          ;; redefining the classes causes interim circularities
    6672           ;; with the old ASDF during upgrade, and many implementations bork
     6692          ;; with the old ASDF during upgrade, and many implementations bork
    66736693          '((#:compile-concatenated-source-op (#:operation) ()))))
    66746694    (loop :for name :in redefined-functions
     
    66786698              #-clisp (fmakunbound sym)))
    66796699    (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
    6680                         (find-symbol* s p nil)))
    6681              (asyms (l) (mapcar #'asym l)))
     6700                        (find-symbol* s p nil)))
     6701             (asyms (l) (mapcar #'asym l)))
    66826702      (loop* :for (name superclasses slots) :in redefined-classes
    6683              :for sym = (find-symbol* name :asdf nil)
    6684              :when (and sym (find-class sym))
    6685              :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
     6703             :for sym = (find-symbol* name :asdf nil)
     6704             :when (and sym (find-class sym))
     6705             :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
    66866706
    66876707
     
    71447164  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
    71457165           #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
    7146            #:do-asdf-cache #:normalize-namestring
    7147            #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
     7166           #:do-asdf-cache #:normalize-namestring
     7167           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
     7168           #:clear-configuration-and-retry #:retry))
    71487169(in-package :asdf/cache)
    71497170
     
    71817202      (if (and *asdf-cache* (not override))
    71827203          (funcall fun)
    7183           (let ((*asdf-cache* (make-hash-table :test 'equal)))
    7184             (funcall fun)))))
     7204          (loop
     7205            (restart-case
     7206                (let ((*asdf-cache* (make-hash-table :test 'equal)))
     7207                  (return (funcall fun)))
     7208              (retry ()
     7209                :report (lambda (s)
     7210                          (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
     7211              (clear-configuration-and-retry ()
     7212                :report (lambda (s)
     7213                          (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
     7214                (clear-configuration)))))))
    71857215
    71867216  (defmacro with-asdf-cache ((&key key override) &body body)
     
    73097339    ;; Invalidate all systems but ASDF itself, if registered.
    73107340    (loop :for name :being :the :hash-keys :of *defined-systems*
    7311           :unless (equal name "asdf")
    7312             :do (clear-defined-system name)))
     7341          :unless (equal name "asdf")
     7342            :do (clear-defined-system name)))
    73137343
    73147344  (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
     
    75637593FOUNDP is true when a system was found,
    75647594either a new unregistered one or a previously registered one.
    7565 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
    7566 PATHNAME when not null is a path from where to load the system,
     7595FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
     7596PATHNAME when not null is a path from which to load the system,
    75677597either associated with FOUND-SYSTEM, or with the PREVIOUS system.
    75687598PREVIOUS when not null is a previously loaded SYSTEM object of same name.
    75697599PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
    7570     (with-asdf-cache (:key `(locate-system ,name))
    7571       (let* ((name (coerce-name name))
    7572              (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    7573              (previous (cdr in-memory))
    7574              (previous (and (typep previous 'system) previous))
    7575              (previous-time (car in-memory))
    7576              (found (search-for-system-definition name))
    7577              (found-system (and (typep found 'system) found))
    7578              (pathname (ensure-pathname
    7579                         (or (and (typep found '(or pathname string)) (pathname found))
    7580                             (and found-system (system-source-file found-system))
    7581                             (and previous (system-source-file previous)))
    7582                         :want-absolute t :resolve-symlinks *resolve-symlinks*))
    7583              (foundp (and (or found-system pathname previous) t)))
    7584         (check-type found (or null pathname system))
    7585         (unless (check-not-old-asdf-system name pathname)
    7586           (cond
    7587             (previous (setf found nil pathname nil))
    7588             (t
    7589              (setf found (sysdef-preloaded-system-search "asdf"))
    7590              (assert (typep found 'system))
    7591              (setf found-system found pathname nil))))
    7592         (values foundp found-system pathname previous previous-time))))
     7600    (let* ((name (coerce-name name))
     7601           (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
     7602           (previous (cdr in-memory))
     7603           (previous (and (typep previous 'system) previous))
     7604           (previous-time (car in-memory))
     7605           (found (search-for-system-definition name))
     7606           (found-system (and (typep found 'system) found))
     7607           (pathname (ensure-pathname
     7608                      (or (and (typep found '(or pathname string)) (pathname found))
     7609                          (and found-system (system-source-file found-system))
     7610                          (and previous (system-source-file previous)))
     7611                      :want-absolute t :resolve-symlinks *resolve-symlinks*))
     7612           (foundp (and (or found-system pathname previous) t)))
     7613      (check-type found (or null pathname system))
     7614      (unless (check-not-old-asdf-system name pathname)
     7615        (cond
     7616          (previous (setf found nil pathname nil))
     7617          (t
     7618           (setf found (sysdef-preloaded-system-search "asdf"))
     7619           (assert (typep found 'system))
     7620           (setf found-system found pathname nil))))
     7621      (values foundp found-system pathname previous previous-time)))
    75937622
    75947623  (defmethod find-system ((name string) &optional (error-p t))
     
    75977626        (unless (equal name primary-name)
    75987627          (find-system primary-name nil)))
    7599       (loop
    7600         (restart-case
    7601             (multiple-value-bind (foundp found-system pathname previous previous-time)
    7602                 (locate-system name)
    7603               (when (and found-system (eq found-system previous)
    7604                          (or (first (gethash `(find-system ,name) *asdf-cache*))
    7605                              (and *immutable-systems* (gethash name *immutable-systems*))))
    7606                 (return found-system))
    7607               (assert (eq foundp (and (or found-system pathname previous) t)))
    7608               (let ((previous-pathname (and previous (system-source-file previous)))
    7609                     (system (or previous found-system)))
    7610                 (when (and found-system (not previous))
    7611                   (register-system found-system))
    7612                 (when (and system pathname)
    7613                   (setf (system-source-file system) pathname))
    7614                 (when (and pathname
    7615                            (let ((stamp (get-file-stamp pathname)))
    7616                              (and stamp
    7617                                   (not (and previous
    7618                                             (or (pathname-equal pathname previous-pathname)
    7619                                                 (and pathname previous-pathname
    7620                                                      (pathname-equal
    7621                                                       (physicalize-pathname pathname)
    7622                                                       (physicalize-pathname previous-pathname))))
    7623                                             (stamp<= stamp previous-time))))))
    7624                   ;; only load when it's a pathname that is different or has newer content, and not an old asdf
    7625                   (load-asd pathname :name name)))
    7626               (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
    7627                 (return
    7628                   (cond
    7629                     (in-memory
    7630                      (when pathname
    7631                        (setf (car in-memory) (get-file-stamp pathname)))
    7632                      (cdr in-memory))
    7633                     (error-p
    7634                      (error 'missing-component :requires name))))))
    7635           (reinitialize-source-registry-and-retry ()
    7636             :report (lambda (s)
    7637                       (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
    7638             (unset-asdf-cache-entry `(locate-system ,name))
    7639             (initialize-source-registry)))))))
    7640 
     7628      (or (and *immutable-systems* (gethash name *immutable-systems*)
     7629               (cdr (system-registered-p name)))
     7630          (multiple-value-bind (foundp found-system pathname previous previous-time)
     7631              (locate-system name)
     7632            (assert (eq foundp (and (or found-system pathname previous) t)))
     7633            (let ((previous-pathname (and previous (system-source-file previous)))
     7634                  (system (or previous found-system)))
     7635              (when (and found-system (not previous))
     7636                (register-system found-system))
     7637              (when (and system pathname)
     7638                (setf (system-source-file system) pathname))
     7639              (when (and pathname
     7640                         (let ((stamp (get-file-stamp pathname)))
     7641                           (and stamp
     7642                                (not (and previous
     7643                                          (or (pathname-equal pathname previous-pathname)
     7644                                              (and pathname previous-pathname
     7645                                                   (pathname-equal
     7646                                                    (physicalize-pathname pathname)
     7647                                                    (physicalize-pathname previous-pathname))))
     7648                                          (stamp<= stamp previous-time))))))
     7649                ;; only load when it's a pathname that is different or has newer content, and not an old asdf
     7650                (load-asd pathname :name name)))
     7651            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
     7652              (cond
     7653                (in-memory
     7654                 (when pathname
     7655                   (setf (car in-memory) (get-file-stamp pathname)))
     7656                 (cdr in-memory))
     7657                (error-p
     7658                 (error 'missing-component :requires name))
     7659                (t ;; not found: don't keep negative cache, see lp#1335323
     7660                 (unset-asdf-cache-entry `(locate-system ,name))
     7661                 (return-from find-system nil)))))))))
    76417662;;;; -------------------------------------------------------------------------
    76427663;;;; Finding components
     
    77487769                     (eq (missing-required-by c) component)
    77497770                     (equal (missing-requires c) name))))
    7750           (unless (component-parent component)
    7751             (let ((name (coerce-name name)))
    7752               (unset-asdf-cache-entry `(find-system ,name))
    7753               (unset-asdf-cache-entry `(locate-system ,name))))))))
     7771          (unless (component-parent component)
     7772            (let ((name (coerce-name name)))
     7773              (unset-asdf-cache-entry `(find-system ,name))
     7774              (unset-asdf-cache-entry `(locate-system ,name))))))))
    77547775
    77557776
     
    90499070
    90509071  (defmethod component-depends-on ((o prepare-op) (s system))
    9051     `((,*load-system-operation* ,@(component-sideway-dependencies s))))
     9072    (loop :for (o . cs) :in (call-next-method)
     9073          :collect (cons (if (eq o 'load-op) *load-system-operation* o) cs)))
    90529074
    90539075  (defclass build-op (non-propagating-operation) ()
     
    90609082that will load the system in the current image, and its typically LOAD-OP."))
    90619083  (defmethod component-depends-on ((o build-op) (c component))
    9062     `((,(or (component-build-operation c) *load-system-operation*) ,c)))
     9084    `((,(or (component-build-operation c) *load-system-operation*) ,c)
     9085      ,@(call-next-method)))
    90639086
    90649087  (defun make (system &rest keys)
     
    91649187    ;; If we're in the middle of something, restart it.
    91659188    (when *asdf-cache*
    9166       (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache*
    9167                       :when (eq x 'find-system) :collect y)))
     9189      (let ((l (loop :for k :being :the hash-keys :of *asdf-cache*
     9190                     :when (eq (first k) 'find-system) :collect (second k))))
    91689191        (clrhash *asdf-cache*)
    91699192        (dolist (s l) (find-system s nil)))))
     
    1068410707
    1068510708
    10686 ;;; Backward compatibility with pre-3.1.1 names
     10709;;; Backward compatibility with pre-3.1.2 names
    1068710710(defclass fasl-op (selfward-operation)
    1068810711  ((selfward-operation :initform 'compile-bundle-op :allocation :class)))
     
    1097711000
    1097811001(with-upgradability ()
    10979   (defparameter *defpackage-forms* '(cl:defpackage uiop:define-package))
     11002  (defparameter *defpackage-forms* '(defpackage define-package))
    1098011003
    1098111004  (defun initial-package-inferred-systems-table ()
     
    1122311246   #:operation-definition-warning #:operation-definition-error
    1122411247
    11225    #:try-recompiling
     11248   #:try-recompiling ; restarts
    1122611249   #:retry
    11227    #:accept                     ; restarts
     11250   #:accept
    1122811251   #:coerce-entry-to-directory
    1122911252   #:remove-entry-from-registry
     11253   #:clear-configuration-and-retry
     11254
    1123011255
    1123111256   #:*encoding-detection-hook*
     
    1126311288   #:system-source-registry
    1126411289   #:user-source-registry-directory
    11265    #:system-source-registry-directory))
     11290   #:system-source-registry-directory
     11291   ))
    1126611292
    1126711293;;;; ---------------------------------------------------------------------------
     
    1127011296(uiop/package:define-package :asdf/user
    1127111297  (:nicknames :asdf-user)
    11272   ;; NB: releases before 3.1.1 this :use'd only uiop/package instead of uiop below.
     11298  ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below.
    1127311299  ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop.
    1127411300  ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo.
Note: See TracChangeset for help on using the changeset viewer.