Changeset 14714
- Timestamp:
- 07/18/14 17:03:20 (8 years ago)
- Location:
- trunk/abcl
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/doc/asdf/asdf.texinfo
r14713 r14714 910 910 @end defun 911 911 912 @vindex *image-dump-hook* 912 913 This function is pushed onto the @code{uiop:*image-dump-hook*} by default, 913 914 which means that if you save an image using @code{uiop:dump-image}, … … 2389 2390 @end itemize 2390 2391 2392 @cindex ASDF-USER package 2391 2393 When system definitions are loaded from @file{.asd} files, 2392 a new scratch package is created for them to load into, 2393 so that different systems do not overwrite each others operations. 2394 The user may also wish to (and is recommended to) 2395 include @code{defpackage} and @code{in-package} forms 2396 in his system definition files, however, 2397 so that they can be loaded manually if need be. 2394 they are implicitly loaded into the @code{ASDF-USER} package, 2395 which uses @code{ASDF}, @code{UIOP} and @code{UIOP/COMMON-LISP}@footnote{ 2396 Note that between releases 2.27 and 3.0.3, only @code{UIOP/PACKAGE}, 2397 not all of @code{UIOP}, was used; if you want your code to work 2398 with releases earlier than 3.1.2, you may have to explicitly define a package 2399 that uses @code{UIOP}, or use proper package prefix to your symbols, as in 2400 @code{uiop:version<}.} 2401 Programmers who do anything non-trivial in a @file{.asd} file, 2402 such as defining new variables, functions or classes, 2403 should include @code{defpackage} and @code{in-package} forms in this file, 2404 so they will not overwrite each others' extensions. 2405 Such forms might also help the files behave identically 2406 if loaded manually with @code{cl:load} for development or debugging, 2407 though we recommend you use the function @code{asdf::load-asd} instead, 2408 which the @code{slime-asdf} contrib knows about. 2398 2409 2399 2410 The default value of @code{*system-definition-search-functions*} 2400 is a list of t wofunctions.2411 is a list of three functions. 2401 2412 The first function looks in each of the directories given 2402 2413 by evaluating members of @code{*central-registry*} 2403 for a file whose name is the name of the system and whose type is @file{asd} .2404 The first such file is returned,2414 for a file whose name is the name of the system and whose type is @file{asd}; 2415 the first such file is returned, 2405 2416 whether or not it turns out to actually define the appropriate system. 2406 2417 The second function does something similar, 2407 for the directories specified in the @code{source-registry}. 2408 Hence, it is strongly advised to define a system 2409 @var{foo} in the corresponding file @var{foo.asd}. 2418 for the directories specified in the @code{source-registry}, 2419 but searches the filesystem only once and caches its results. 2420 The third function makes the @code{package-inferred-system} extension work, 2421 @pxref{The package-inferred-system extension}. 2422 2423 Because of the way these search functions are defined, 2424 you should put the definition for a system 2425 @var{foo} in a file named @file{foo.asd}, 2426 in a directory that is 2427 in the central registry or 2428 which can be found using the 2429 source registry configuration. 2430 2431 @c FIXME: Move this discussion to the system definition grammar, or somewhere else. 2432 @anchor{System names} 2433 @cindex System names 2434 @cindex Primary system name 2435 @findex primary-system-name 2436 It is often useful to define multiple systems in a same file, 2437 but ASDF can only locate a system's definition file based on the system 2438 name. 2439 For this reason, 2440 ASDF 3's system search algorithm has been extended to 2441 allow a file @file{foo.asd} to contain 2442 secondary systems named @var{foo/bar}, @var{foo/baz}, @var{foo/quux}, etc., 2443 in addition to the primary system named @var{foo}. 2444 The first component of a system name, 2445 separated by the slash character, @code{/}, 2446 is called the primary name of a system. 2447 The primary name may be 2448 extracted by function @code{asdf::primary-system-name}; 2449 when ASDF 3 is told to find a system whose name has a slash, 2450 it will first attempt to load the corresponding primary system, 2451 and will thus see any such definitions, and/or any 2452 definition of a @code{package-inferred-system}.@footnote{ 2453 ASDF 2.26 and earlier versions 2454 do not support this primary system name convention. 2455 With these versions of ASDF 2456 you must explicitly load @file{foo.asd} 2457 before you can use system @var{foo/bar} defined therein, 2458 e.g. using @code{(asdf:find-system "foo")}. 2459 We do not support ASDF 2, and recommend that you should upgrade to ASDF 3. 2460 } 2461 If your file @file{foo.asd} also defines systems 2462 that do not follow this convention, e.g., a system named @var{foo-test}, 2463 ASDF will not be able to automatically locate a definition for these systems, 2464 and will only see their definition 2465 if you explicitly find or load the primary system 2466 using e.g. @code{(asdf:find-system "foo")} before you try to use them. 2467 We strongly recommend against this practice, 2468 though it is currently supported for backward compatibility. 2469 2470 @end defun 2471 2472 @defun primary-system-name name 2473 2474 Internal (not exported) function, @code{asdf::primary-system-name}. 2475 Returns the primary system name (the portion before 2476 the slash, @code{/}, in a secondary system name) from @var{name}. 2477 2478 @end defun 2479 2480 @defun locate-system name 2481 2482 This function should typically @emph{not} be invoked directly. It is 2483 exported as part of the API only for programmers who wish to provide 2484 their own @code{*system-definition-search-functions*}. 2485 2486 Given a system @var{name} designator, 2487 try to locate where to load the system definition from. 2488 @c (This does not include the loading of the system definition, 2489 @c which is done by @code{find-system}, 2490 @c or the loading of the system itself, which is done by @code{load-system}; 2491 @c however, for systems the definition of which has already been loaded, 2492 @c @code{locate-system} may return an object of class @code{system}.) 2493 Returns five values: @var{foundp}, @var{found-system}, @var{pathname}, 2494 @var{previous}, and @var{previous-time}. 2495 @var{foundp} is true when a system was found, 2496 either a new as yet unregistered one, or a previously registered one. 2497 The @var{found-system} return value 2498 will be a @code{system} object, if a system definition is found in your 2499 source registry. 2500 @c This system may be registered (by @code{register-system}) or may not, if 2501 @c it's preloaded code. Fare writes: 2502 @c In the case of preloaded code, as for "asdf", "uiop", etc., 2503 @c themselves, the system objects are not registered until after they are 2504 @c initially located by sysdef-preloaded-system-search as a fallback when 2505 @c no source code was found. 2506 The system definition will @emph{not} be 2507 loaded if it hasn't been loaded already. 2508 @var{pathname} when not null is a path from which to load the system, 2509 either associated with @var{found-system}, or with the @var{previous} system. 2510 If @var{previous} is not null, it will be a @emph{previously loaded} 2511 @code{system} object of the same name (note that the system 2512 @emph{definition} is previously-loaded: the system itself may or may not be). 2513 @var{previous-time} when not null is 2514 the timestamp of the previous system definition file, at the 2515 time when the @var{previous} system definition was loaded. 2516 2517 For example, if your current registry has @file{foo.asd} in 2518 @file{/current/path/to/foo.asd}, 2519 but system @code{foo} was previously loaded from @file{/previous/path/to/foo.asd} 2520 then @var{locate-system} will return the following values: 2521 @enumerate 2522 @item 2523 @var{foundp} will be @code{T}, 2524 @item 2525 @var{found-system} will be @code{NIL}, 2526 @item 2527 @var{pathname} will be @code{#p"/current/path/to/foo.asd"}, 2528 @item 2529 @var{previous} will be an object of type @code{SYSTEM} with 2530 @code{system-source-file} slot value of 2531 @code{#p"/previous/path/to/foo.asd"} 2532 @item 2533 @var{previous-time} will be the timestamp of 2534 @code{#p"/previous/path/to/foo.asd"} at the time it was loaded. 2535 @end enumerate 2410 2536 @end defun 2411 2537 … … 2726 2852 component classes and specializing methods on the new component class. 2727 2853 2728 @ emph{FIXME: this should perhaps be explained more throughly,2729 not only by example ...} 2854 @c FIXME: this should perhaps be explained more throughly, 2855 @c not only by example ... 2730 2856 2731 2857 As an example, suppose we have some implementation-dependent … … 2770 2896 @c here.... Also needs to be revised to be coherent. 2771 2897 2772 To be successfully build able, this graph of actions but be acyclic.2773 If, as a user, extender or implementer of ASDF, you fail2774 to keep the dependency graph without cycles,2775 ASDF will fail loudly as it eventually finds one.2898 To be successfully build-able, this graph of actions must be acyclic. 2899 If, as a user, extender or implementer of ASDF, you introduce 2900 a cycle into the dependency graph, 2901 ASDF will fail loudly. 2776 2902 To clearly distinguish the direction of dependencies, 2777 2903 ASDF 3 uses the words @emph{requiring} and @emph{required} … … 2964 3090 because it is easier to setup in a portable way across users and implementations. 2965 3091 2966 Add tionally, some people dislike truename,3092 Additionally, some people dislike truename, 2967 3093 either because it is very slow on their system, or 2968 3094 because they are using content-addressed storage where the truename of a file … … 3252 3378 ASDF will skip to next configuration if it's an empty string. 3253 3379 It will @code{READ} the string as a SEXP in the DSL 3254 if it begins with a paren @code{(} 3255 and it will be interpreted much like @code{TEXINPUTS} 3256 list of paths, where3380 if it begins with a paren @code{(}, 3381 otherwise it will be interpreted much like @code{TEXINPUTS}, 3382 as a list of paths, where 3257 3383 3258 3384 * paths are separated … … 3710 3836 ;; the pathname to be translated and the matching 3711 3837 ;; DIRECTORY-DESIGNATOR 3712 LAMBDA ;; A form which evalu tates to a function taking two arguments:3838 LAMBDA ;; A form which evaluates to a function taking two arguments: 3713 3839 ;; the pathname to be translated and the matching 3714 3840 ;; DIRECTORY-DESIGNATOR … … 3771 3897 If the @code{translate-pathname} mechanism cannot achieve a desired 3772 3898 translation, the user may provide a function which provides the 3773 required algorith im. Such a translation function is specified by3899 required algorithm. Such a translation function is specified by 3774 3900 supplying a list as the second @code{directory-designator} 3775 3901 the first element of which is the keyword @code{:function}, … … 5614 5740 5615 5741 @bye 5742 5743 @c LocalWords: clbuild tarballs defsystem Quicklisp initarg uiop fasl 5744 @c LocalWords: namestring initargs fasls -
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
r14713 r14714 1 1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- 2 ;;; This is ASDF 3.1.2. 2: Another System Definition Facility.2 ;;; This is ASDF 3.1.2.9: Another System Definition Facility. 3 3 ;;; 4 4 ;;; Feedback, bug reports, and patches are all welcome: … … 403 403 (t (push name intern))))))) 404 404 (labels ((sort-names (names) 405 (sort names#'string<))405 (sort (copy-list names) #'string<)) 406 406 (table-keys (table) 407 407 (loop :for k :being :the :hash-keys :of table :collect k)) … … 846 846 (uiop/package:define-package :uiop/common-lisp 847 847 (: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) 850 850 (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) 851 851 #+allegro (:intern #:*acl-warn-save*) … … 856 856 #:make-broadcast-stream #:file-namestring) 857 857 #+genera (:shadowing-import-from :scl #:boolean) 858 #+genera (:export #:boolean #:ensure-directories-exist )858 #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) 859 859 #+mcl (:shadow #:user-homedir-pathname)) 860 860 (in-package :uiop/common-lisp) … … 936 936 #+genera 937 937 (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)))) 938 942 (unless (fboundp 'ensure-directories-exist) 939 943 (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))) 941 952 942 953 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick … … 1214 1225 ;;; Characters 1215 1226 (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))) 1217 1228 #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow??? 1218 1229 (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) … … 1391 1402 (function fun) 1392 1403 ((or boolean keyword character number pathname) (constantly fun)) 1393 (hash-table (lambda (x) (gethash x fun)))1404 (hash-table #'(lambda (x) (gethash x fun))) 1394 1405 (symbol (fdefinition fun)) 1395 1406 (cons (if (eq 'lambda (car fun)) … … 1751 1762 "The operating system of the current host" 1752 1763 (first-feature 1753 '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! 1764 '(:cygwin 1765 (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! 1754 1766 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd 1755 1767 (: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 1757 1771 :genera))) 1758 1772 … … 2553 2567 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." 2554 2568 (let ((sub (when maybe-subpath (pathname maybe-subpath))) 2555 2569 (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) 2556 2570 (or (and base (subpathp sub base)) sub))) 2557 2571 … … 3298 3312 #+cormanlisp (win32:delete-directory directory-pathname) 3299 3313 #+ecl (si:rmdir directory-pathname) 3314 #+genera (fs:delete-directory directory-pathname) 3300 3315 #+lispworks (lw:delete-directory directory-pathname) 3301 3316 #+mkcl (mkcl:rmdir directory-pathname) … … 3304 3319 `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) 3305 3320 #+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) 3307 3322 (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera 3308 3323 … … 3338 3353 'delete-filesystem-tree directory-pathname)) 3339 3354 (:ignore nil))) 3340 #-(or allegro cmu clozure sbcl scl)3355 #-(or allegro cmu clozure genera sbcl scl) 3341 3356 ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, 3342 3357 ;; except on implementations where we can prevent DIRECTORY from following symlinks; … … 3348 3363 directory-pathname :if-does-not-exist if-does-not-exist) 3349 3364 #+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) 3351 3366 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) 3352 3367 `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later … … 3996 4011 (afterf (gensym "AFTER"))) 3997 4012 `(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))) 3999 4016 ,@(when after 4000 4017 (assert pathnamep) … … 4121 4138 #+ecl (si:quit code) 4122 4139 #+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) 4124 4141 #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) 4125 4142 #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ? … … 4145 4162 #+abcl 4146 4163 (loop :for i :from 0 4147 4148 4164 :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do 4165 (safe-format! stream "~&~D: ~A~%" i frame)) 4149 4166 #+allegro 4150 4167 (let ((*terminal-io* stream) … … 4170 4187 #+(or ecl mkcl) 4171 4188 (let* ((top (si:ihs-top)) 4172 4173 4189 (repeats (if count (min top count) top)) 4190 (backtrace (loop :for ihs :from 0 :below top 4174 4191 :collect (list (si::ihs-fun ihs) 4175 4192 (si::ihs-env ihs))))) 4176 4193 (loop :for i :from 0 :below repeats 4177 4178 4194 :for frame :in (nreverse backtrace) :do 4195 (safe-format! stream "~&~D: ~S~%" i frame))) 4179 4196 #+gcl 4180 4197 (let ((*debug-io* stream)) 4181 4198 (ignore-errors 4182 4199 (with-safe-io-syntax () 4183 4184 4185 4200 (if condition 4201 (conditions::condition-backtrace condition) 4202 (system::simple-backtrace))))) 4186 4203 #+lispworks 4187 4204 (let ((dbg::*debugger-stack* … … 4197 4214 #+xcl 4198 4215 (loop :for i :from 0 :below (or count most-positive-fixnum) 4199 4200 4216 :for frame :in (extensions:backtrace-as-list) :do 4217 (safe-format! stream "~&~D: ~S~%" i frame))) 4201 4218 4202 4219 (defun print-backtrace (&rest keys &key stream count condition) … … 4298 4315 #-(or sbcl allegro) 4299 4316 (unless (eq *image-dumped-p* :executable) 4300 4301 4302 4303 4304 4305 4306 4307 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))) 4308 4325 (rest arguments))) 4309 4326 … … 4340 4357 Then, comes the restore process itself: 4341 4358 First, call each function in the RESTORE-HOOK, 4342 in the order they were registered with REGISTER- RESTORE-HOOK.4359 in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK. 4343 4360 Second, evaluate the prelude, which is often Lisp text that is read, 4344 4361 as per EVAL-INPUT. … … 4385 4402 #+clozure prepend-symbols #+clozure (purify t) 4386 4403 #+sbcl compression 4387 #+(and sbcl windows) application-type)4404 #+(and sbcl os-windows) application-type) 4388 4405 "Dump an image of the current Lisp environment at pathname FILENAME, with various options. 4389 4406 … … 4459 4476 ;;--- only save runtime-options for standalone executables 4460 4477 (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. 4462 4479 ;; the default is :console - only works with SBCL 1.1.15 or later. 4463 4480 (when application-type (list :application-type application-type))))) … … 5296 5313 (%wait-process-result 5297 5314 (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) 5299 5316 (let ((%command (%redirected-system-command command input output error-output directory))) 5300 5317 #+(and lispworks os-windows) … … 5313 5330 (ext:system %command)) 5314 5331 #+gcl (system:system %command) 5332 #+genera (error "~S not supported on Genera, cannot run ~S" 5333 '%system %command) 5315 5334 #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) 5316 5335 #+mkcl (mkcl:system %command) … … 6343 6362 be applied to the results to yield a configuration form. Current 6344 6363 values 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 6346 6365 (remove-if 6347 6366 'hidden-pathname-p … … 6640 6659 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 6641 6660 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 6642 (asdf-version "3.1.2. 2")6661 (asdf-version "3.1.2.9") 6643 6662 (existing-version (asdf-version))) 6644 6663 (setf *asdf-version* asdf-version) … … 6652 6671 (when-upgrading () 6653 6672 (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. 6654 6655 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. 6656 6675 '(#:component-relative-pathname #:component-parent-pathname ;; component 6657 6676 #:source-file-type 6658 6677 #:find-system #:system-source-file #:system-relative-pathname ;; system 6659 6660 6661 6662 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 6663 6682 #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan 6664 6665 6666 6667 6668 6669 6670 6671 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 6672 6691 ;; redefining the classes causes interim circularities 6673 6692 ;; with the old ASDF during upgrade, and many implementations bork 6674 6693 '((#:compile-concatenated-source-op (#:operation) ())))) 6675 6694 (loop :for name :in redefined-functions … … 6679 6698 #-clisp (fmakunbound sym))) 6680 6699 (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf)) 6681 6682 6700 (find-symbol* s p nil))) 6701 (asyms (l) (mapcar #'asym l))) 6683 6702 (loop* :for (name superclasses slots) :in redefined-classes 6684 6685 6686 6703 :for sym = (find-symbol* name :asdf nil) 6704 :when (and sym (find-class sym)) 6705 :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))))))) 6687 6706 6688 6707 … … 7145 7164 (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp 7146 7165 #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache 7147 #:do-asdf-cache #:normalize-namestring 7148 #: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)) 7149 7169 (in-package :asdf/cache) 7150 7170 … … 7182 7202 (if (and *asdf-cache* (not override)) 7183 7203 (funcall fun) 7184 (let ((*asdf-cache* (make-hash-table :test 'equal))) 7185 (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))))))) 7186 7215 7187 7216 (defmacro with-asdf-cache ((&key key override) &body body) … … 7310 7339 ;; Invalidate all systems but ASDF itself, if registered. 7311 7340 (loop :for name :being :the :hash-keys :of *defined-systems* 7312 7313 7341 :unless (equal name "asdf") 7342 :do (clear-defined-system name))) 7314 7343 7315 7344 (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) … … 7564 7593 FOUNDP is true when a system was found, 7565 7594 either a new unregistered one or a previously registered one. 7566 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is7567 PATHNAME when not null is a path from wh ereto load the system,7595 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed. 7596 PATHNAME when not null is a path from which to load the system, 7568 7597 either associated with FOUND-SYSTEM, or with the PREVIOUS system. 7569 7598 PREVIOUS when not null is a previously loaded SYSTEM object of same name. 7570 7599 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." 7571 (with-asdf-cache (:key `(locate-system ,name)) 7572 (let* ((name (coerce-name name)) 7573 (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk 7574 (previous (cdr in-memory)) 7575 (previous (and (typep previous 'system) previous)) 7576 (previous-time (car in-memory)) 7577 (found (search-for-system-definition name)) 7578 (found-system (and (typep found 'system) found)) 7579 (pathname (ensure-pathname 7580 (or (and (typep found '(or pathname string)) (pathname found)) 7581 (and found-system (system-source-file found-system)) 7582 (and previous (system-source-file previous))) 7583 :want-absolute t :resolve-symlinks *resolve-symlinks*)) 7584 (foundp (and (or found-system pathname previous) t))) 7585 (check-type found (or null pathname system)) 7586 (unless (check-not-old-asdf-system name pathname) 7587 (cond 7588 (previous (setf found nil pathname nil)) 7589 (t 7590 (setf found (sysdef-preloaded-system-search "asdf")) 7591 (assert (typep found 'system)) 7592 (setf found-system found pathname nil)))) 7593 (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))) 7594 7622 7595 7623 (defmethod find-system ((name string) &optional (error-p t)) … … 7598 7626 (unless (equal name primary-name) 7599 7627 (find-system primary-name nil))) 7600 (loop 7601 (restart-case 7602 (multiple-value-bind (foundp found-system pathname previous previous-time) 7603 (locate-system name) 7604 (when (and found-system (eq found-system previous) 7605 (or (first (gethash `(find-system ,name) *asdf-cache*)) 7606 (and *immutable-systems* (gethash name *immutable-systems*)))) 7607 (return found-system)) 7608 (assert (eq foundp (and (or found-system pathname previous) t))) 7609 (let ((previous-pathname (and previous (system-source-file previous))) 7610 (system (or previous found-system))) 7611 (when (and found-system (not previous)) 7612 (register-system found-system)) 7613 (when (and system pathname) 7614 (setf (system-source-file system) pathname)) 7615 (when (and pathname 7616 (let ((stamp (get-file-stamp pathname))) 7617 (and stamp 7618 (not (and previous 7619 (or (pathname-equal pathname previous-pathname) 7620 (and pathname previous-pathname 7621 (pathname-equal 7622 (physicalize-pathname pathname) 7623 (physicalize-pathname previous-pathname)))) 7624 (stamp<= stamp previous-time)))))) 7625 ;; only load when it's a pathname that is different or has newer content, and not an old asdf 7626 (load-asd pathname :name name))) 7627 (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed 7628 (return 7629 (cond 7630 (in-memory 7631 (when pathname 7632 (setf (car in-memory) (get-file-stamp pathname))) 7633 (cdr in-memory)) 7634 (error-p 7635 (error 'missing-component :requires name)))))) 7636 (reinitialize-source-registry-and-retry () 7637 :report (lambda (s) 7638 (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) 7639 (unset-asdf-cache-entry `(locate-system ,name)) 7640 (initialize-source-registry))))))) 7641 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))))))))) 7642 7662 ;;;; ------------------------------------------------------------------------- 7643 7663 ;;;; Finding components … … 7749 7769 (eq (missing-required-by c) component) 7750 7770 (equal (missing-requires c) name)))) 7751 7752 7753 7754 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)))))))) 7755 7775 7756 7776 … … 9050 9070 9051 9071 (defmethod component-depends-on ((o prepare-op) (s system)) 9052 `((,*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))) 9053 9074 9054 9075 (defclass build-op (non-propagating-operation) () … … 9061 9082 that will load the system in the current image, and its typically LOAD-OP.")) 9062 9083 (defmethod component-depends-on ((o build-op) (c component)) 9063 `((,(or (component-build-operation c) *load-system-operation*) ,c))) 9084 `((,(or (component-build-operation c) *load-system-operation*) ,c) 9085 ,@(call-next-method))) 9064 9086 9065 9087 (defun make (system &rest keys) … … 11224 11246 #:operation-definition-warning #:operation-definition-error 11225 11247 11226 #:try-recompiling 11248 #:try-recompiling ; restarts 11227 11249 #:retry 11228 #:accept ; restarts11250 #:accept 11229 11251 #:coerce-entry-to-directory 11230 11252 #:remove-entry-from-registry 11253 #:clear-configuration-and-retry 11254 11231 11255 11232 11256 #:*encoding-detection-hook* … … 11264 11288 #:system-source-registry 11265 11289 #:user-source-registry-directory 11266 #:system-source-registry-directory)) 11290 #:system-source-registry-directory 11291 )) 11267 11292 11268 11293 ;;;; ---------------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.