Changeset 13681
- Timestamp:
- May 6, 2010, 2:36:10 AM (10 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/tools/asdf.lisp
r13021 r13681 1 ;;; This is asdf: Another System Definition Facility.2 ;;; hash - $Format:%H$1 ;;; -*- mode: common-lisp; package: asdf; -*- 2 ;;; This is ASDF: Another System Definition Facility. 3 3 ;;; 4 ;;; Local Variables: 5 ;;; mode: lisp 6 ;;; End: 7 ;;; 8 ;;; Feedback, bug reports, and patches are all welcome: please mail to 9 ;;; <asdf-devel@common-lisp.net>. But note first that the canonical 10 ;;; source for asdf is presently on common-lisp.net at 11 ;;; <URL:http://common-lisp.net/project/asdf/> 4 ;;; Feedback, bug reports, and patches are all welcome: 5 ;;; please mail to <asdf-devel@common-lisp.net>. 6 ;;; Note first that the canonical source for ASDF is presently 7 ;;; <URL:http://common-lisp.net/project/asdf/>. 12 8 ;;; 13 9 ;;; If you obtained this copy from anywhere else, and you experience … … 20 16 21 17 ;;; -- LICENSE START 22 ;;; (This is the MIT / X Consortium license as taken from 18 ;;; (This is the MIT / X Consortium license as taken from 23 19 ;;; http://www.opensource.org/licenses/mit-license.html on or about 24 20 ;;; Monday; July 13, 2009) 25 21 ;;; 26 ;;; Copyright (c) 2001-20 09Daniel Barlow and contributors22 ;;; Copyright (c) 2001-2010 Daniel Barlow and contributors 27 23 ;;; 28 24 ;;; Permission is hereby granted, free of charge, to any person obtaining … … 47 43 ;;; -- LICENSE END 48 44 49 ;;; the problem with writing a defsystem replacement is bootstrapping:50 ;;; we can't use defsystem to compile it. Hence, all in one file 45 ;;; The problem with writing a defsystem replacement is bootstrapping: 46 ;;; we can't use defsystem to compile it. Hence, all in one file. 51 47 52 48 #+xcvb (module ()) 53 49 54 (defpackage #:asdf 55 (:documentation "Another System Definition Facility") 56 (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command 57 #:system-definition-pathname #:find-component ; miscellaneous 58 #:compile-system #:load-system #:test-system 59 #:compile-op #:load-op #:load-source-op 60 #:test-op 61 #:operation ; operations 62 #:feature ; sort-of operation 63 #:version ; metaphorically sort-of an operation 64 65 #:input-files #:output-files #:perform ; operation methods 66 #:operation-done-p #:explain 67 68 #:component #:source-file 69 #:c-source-file #:cl-source-file #:java-source-file 70 #:static-file 71 #:doc-file 72 #:html-file 73 #:text-file 74 #:source-file-type 75 #:module ; components 76 #:system 77 #:unix-dso 78 79 #:module-components ; component accessors 80 #:component-pathname 81 #:component-relative-pathname 82 #:component-name 83 #:component-version 84 #:component-parent 85 #:component-property 86 #:component-system 87 88 #:component-depends-on 89 90 #:system-description 91 #:system-long-description 92 #:system-author 93 #:system-maintainer 94 #:system-license 95 #:system-licence 96 #:system-source-file 97 #:system-relative-pathname 98 #:map-systems 99 100 #:operation-on-warnings 101 #:operation-on-failure 102 103 ;#:*component-parent-pathname* 104 #:*system-definition-search-functions* 105 #:*central-registry* ; variables 106 #:*compile-file-warnings-behaviour* 107 #:*compile-file-failure-behaviour* 108 #:*asdf-revision* 109 #:*resolve-symlinks* 110 111 #:operation-error #:compile-failed #:compile-warned #:compile-error 112 #:error-component #:error-operation 113 #:system-definition-error 114 #:missing-component 115 #:missing-component-of-version 116 #:missing-dependency 117 #:missing-dependency-of-version 118 #:circular-dependency ; errors 119 #:duplicate-names 120 121 #:try-recompiling 122 #:retry 123 #:accept ; restarts 124 #:coerce-entry-to-directory 125 #:remove-entry-from-registry 126 127 #:standard-asdf-method-combination 128 #:around ; protocol assistants 129 130 #:*source-to-target-mappings* 131 #:*default-toplevel-directory* 132 #:*centralize-lisp-binaries* 133 #:*include-per-user-information* 134 #:*map-all-source-files* 135 #:output-files-for-system-and-operation 136 #:*enable-asdf-binary-locations* 137 #:implementation-specific-directory-name) 138 (:use :cl)) 139 140 141 #+nil 142 (error "The author of this file habitually uses #+nil to comment out ~ 143 forms. But don't worry, it was unlikely to work in the New ~ 144 Implementation of Lisp anyway") 145 146 (in-package #:asdf) 147 148 (defvar *asdf-revision* 149 ;; the 1+ hair is to ensure that we don't do an inadvertant find and replace 150 (subseq "REVISION:1.366" (1+ (length "REVISION")))) 151 50 (cl:in-package :cl-user) 51 52 (declaim (optimize (speed 2) (debug 2) (safety 3)) 53 #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 54 55 #+ecl (require :cmp) 56 57 ;;;; Create packages in a way that is compatible with hot-upgrade. 58 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 59 ;;;; See more at the end of the file. 60 61 #+gcl 62 (eval-when (:compile-toplevel :load-toplevel) 63 (defpackage :asdf-utilities (:use :cl)) 64 (defpackage :asdf (:use :cl :asdf-utilities))) 65 66 (eval-when (:load-toplevel :compile-toplevel :execute) 67 #+allegro 68 (setf excl::*autoload-package-name-alist* 69 (remove "asdf" excl::*autoload-package-name-alist* 70 :test 'equalp :key 'car)) 71 (let* ((asdf-version 72 ;; the 1+ helps the version bumping script discriminate 73 (subseq "VERSION:1.717" (1+ (length "VERSION")))) 74 (existing-asdf (find-package :asdf)) 75 (vername '#:*asdf-version*) 76 (versym (and existing-asdf 77 (find-symbol (string vername) existing-asdf))) 78 (existing-version (and versym (boundp versym) (symbol-value versym))) 79 (already-there (equal asdf-version existing-version))) 80 (unless (and existing-asdf already-there) 81 #-gcl 82 (when existing-asdf 83 (format *error-output* 84 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" 85 existing-version asdf-version)) 86 (labels 87 ((rename-away (package) 88 (loop :with name = (package-name package) 89 :for i :from 1 :for new = (format nil "~A.~D" name i) 90 :unless (find-package new) :do 91 (rename-package-name package name new))) 92 (rename-package-name (package old new) 93 (let* ((old-names (cons (package-name package) 94 (package-nicknames package))) 95 (new-names (subst new old old-names :test 'equal)) 96 (new-name (car new-names)) 97 (new-nicknames (cdr new-names))) 98 (rename-package package new-name new-nicknames))) 99 (ensure-exists (name nicknames use) 100 (let* ((previous 101 (remove-duplicates 102 (remove-if 103 #'null 104 (mapcar #'find-package (cons name nicknames))) 105 :from-end t))) 106 (cond 107 (previous 108 ;; do away with packages with conflicting (nick)names 109 (map () #'rename-away (cdr previous)) 110 ;; reuse previous package with same name 111 (let ((p (car previous))) 112 (rename-package p name nicknames) 113 (ensure-use p use) 114 p)) 115 (t 116 (make-package name :nicknames nicknames :use use))))) 117 (find-sym (symbol package) 118 (find-symbol (string symbol) package)) 119 (intern* (symbol package) 120 (intern (string symbol) package)) 121 (remove-symbol (symbol package) 122 (let ((sym (find-sym symbol package))) 123 (when sym 124 (unexport sym package) 125 (unintern sym package)))) 126 (ensure-unintern (package symbols) 127 (dolist (sym symbols) (remove-symbol sym package))) 128 (ensure-shadow (package symbols) 129 (shadow symbols package)) 130 (ensure-use (package use) 131 (dolist (used (reverse use)) 132 (do-external-symbols (sym used) 133 (unless (eq sym (find-sym sym package)) 134 (remove-symbol sym package))) 135 (use-package used package))) 136 (ensure-fmakunbound (package symbols) 137 (loop :for name :in symbols 138 :for sym = (find-sym name package) 139 :when sym :do (fmakunbound sym))) 140 (ensure-export (package export) 141 (let ((syms (loop :for x :in export :collect 142 (intern* x package)))) 143 (do-external-symbols (sym package) 144 (unless (member sym syms) 145 (remove-symbol sym package))) 146 (dolist (sym syms) 147 (export sym package)))) 148 (ensure-package (name &key nicknames use unintern fmakunbound shadow export) 149 (let ((p (ensure-exists name nicknames use))) 150 (ensure-unintern p unintern) 151 (ensure-shadow p shadow) 152 (ensure-export p export) 153 (ensure-fmakunbound p fmakunbound) 154 p))) 155 (macrolet 156 ((pkgdcl (name &key nicknames use export 157 redefined-functions unintern fmakunbound shadow) 158 `(ensure-package 159 ',name :nicknames ',nicknames :use ',use :export ',export 160 :shadow ',shadow 161 :unintern ',(append #-(or gcl ecl) redefined-functions 162 unintern) 163 :fmakunbound ',(append #+(or gcl ecl) redefined-functions 164 fmakunbound)))) 165 (pkgdcl 166 :asdf-utilities 167 :nicknames (#:asdf-extensions) 168 :use (#:common-lisp) 169 :unintern (#:split #:make-collector) 170 :export 171 (#:absolute-pathname-p 172 #:aif 173 #:appendf 174 #:asdf-message 175 #:coerce-name 176 #:directory-pathname-p 177 #:ends-with 178 #:ensure-directory-pathname 179 #:getenv 180 #:get-uid 181 #:length=n-p 182 #:merge-pathnames* 183 #:pathname-directory-pathname 184 #:read-file-forms 185 #:remove-keys 186 #:remove-keyword 187 #:resolve-symlinks 188 #:split-string 189 #:component-name-to-pathname-components 190 #:split-name-type 191 #:system-registered-p 192 #:truenamize 193 #:while-collecting)) 194 (pkgdcl 195 :asdf 196 :use (:common-lisp :asdf-utilities) 197 :redefined-functions 198 (#:perform #:explain #:output-files #:operation-done-p 199 #:perform-with-restarts #:component-relative-pathname 200 #:system-source-file #:operate #:find-component) 201 :unintern 202 (#:*asdf-revision* #:around #:asdf-method-combination 203 #:split #:make-collector) 204 :fmakunbound 205 (#:system-source-file 206 #:component-relative-pathname #:system-relative-pathname 207 #:process-source-registry 208 #:inherit-source-registry #:process-source-registry-directive) 209 :export 210 (#:defsystem #:oos #:operate #:find-system #:run-shell-command 211 #:system-definition-pathname #:find-component ; miscellaneous 212 #:compile-system #:load-system #:test-system 213 #:compile-op #:load-op #:load-source-op 214 #:test-op 215 #:operation ; operations 216 #:feature ; sort-of operation 217 #:version ; metaphorically sort-of an operation 218 #:version-satisfies 219 220 #:input-files #:output-files #:perform ; operation methods 221 #:operation-done-p #:explain 222 223 #:component #:source-file 224 #:c-source-file #:cl-source-file #:java-source-file 225 #:static-file 226 #:doc-file 227 #:html-file 228 #:text-file 229 #:source-file-type 230 #:module ; components 231 #:system 232 #:unix-dso 233 234 #:module-components ; component accessors 235 #:module-components-by-name ; component accessors 236 #:component-pathname 237 #:component-relative-pathname 238 #:component-name 239 #:component-version 240 #:component-parent 241 #:component-property 242 #:component-system 243 244 #:component-depends-on 245 246 #:system-description 247 #:system-long-description 248 #:system-author 249 #:system-maintainer 250 #:system-license 251 #:system-licence 252 #:system-source-file 253 #:system-source-directory 254 #:system-relative-pathname 255 #:map-systems 256 257 #:operation-on-warnings 258 #:operation-on-failure 259 ;;#:*component-parent-pathname* 260 #:*system-definition-search-functions* 261 #:*central-registry* ; variables 262 #:*compile-file-warnings-behaviour* 263 #:*compile-file-failure-behaviour* 264 #:*resolve-symlinks* 265 #:*asdf-verbose* 266 267 #:asdf-version 268 269 #:operation-error #:compile-failed #:compile-warned #:compile-error 270 #:error-name 271 #:error-pathname 272 #:load-system-definition-error 273 #:error-component #:error-operation 274 #:system-definition-error 275 #:missing-component 276 #:missing-component-of-version 277 #:missing-dependency 278 #:missing-dependency-of-version 279 #:circular-dependency ; errors 280 #:duplicate-names 281 282 #:try-recompiling 283 #:retry 284 #:accept ; restarts 285 #:coerce-entry-to-directory 286 #:remove-entry-from-registry 287 288 #:initialize-output-translations 289 #:disable-output-translations 290 #:clear-output-translations 291 #:ensure-output-translations 292 #:apply-output-translations 293 #:compile-file-pathname* 294 #:enable-asdf-binary-locations-compatibility 295 296 #:*default-source-registries* 297 #:initialize-source-registry 298 #:compute-source-registry 299 #:clear-source-registry 300 #:ensure-source-registry 301 #:process-source-registry))) 302 (let* ((version (intern* vername :asdf)) 303 (upvar (intern* '#:*upgraded-p* :asdf)) 304 (upval0 (and (boundp upvar) (symbol-value upvar))) 305 (upval1 (if existing-version (cons existing-version upval0) upval0))) 306 (eval `(progn 307 (defparameter ,version ,asdf-version) 308 (defparameter ,upvar ',upval1)))))))) 309 310 (in-package :asdf) 311 312 ;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 313 #+gcl 314 (eval-when (:compile-toplevel :load-toplevel) 315 (defvar *asdf-version* nil) 316 (defvar *upgraded-p* nil)) 317 (when *upgraded-p* 318 #+ecl 319 (when (find-class 'compile-op nil) 320 (defmethod update-instance-for-redefined-class :after 321 ((c compile-op) added deleted plist &key) 322 (declare (ignore added deleted)) 323 (let ((system-p (getf plist 'system-p))) 324 (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) 325 (when (find-class 'module nil) 326 (eval 327 '(defmethod update-instance-for-redefined-class :after 328 ((m module) added deleted plist &key) 329 (declare (ignorable deleted plist)) 330 (when (member 'components-by-name added) 331 (compute-module-components-by-name m)))))) 332 333 ;;;; ------------------------------------------------------------------------- 334 ;;;; User-visible parameters 335 ;;;; 336 (defun asdf-version () 337 "Exported interface to the version of ASDF currently installed. A string. 338 You can compare this string with e.g.: 339 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")." 340 *asdf-version*) 152 341 153 342 (defvar *resolve-symlinks* t … … 162 351 (defvar *verbose-out* nil) 163 352 353 (defvar *asdf-verbose* t) 354 164 355 (defparameter +asdf-methods+ 165 '(perform explain output-files operation-done-p)) 166 167 (define-method-combination standard-asdf-method-combination () 168 ((around-asdf (around)) 169 (around (:around)) 170 (before (:before)) 171 (primary () :required t) 172 (after (:after))) 173 (flet ((call-methods (methods) 174 (mapcar #'(lambda (method) 175 `(call-method ,method)) 176 methods))) 177 (let* ((form (if (or before after (rest primary)) 178 `(multiple-value-prog1 179 (progn ,@(call-methods before) 180 (call-method ,(first primary) 181 ,(rest primary))) 182 ,@(call-methods (reverse after))) 183 `(call-method ,(first primary)))) 184 (standard-form (if around 185 `(call-method ,(first around) 186 (,@(rest around) 187 (make-method ,form))) 188 form))) 189 (if around-asdf 190 `(call-method ,(first around-asdf) 191 (,@(rest around-asdf) (make-method ,standard-form))) 192 standard-form)))) 193 194 (setf (documentation 'standard-asdf-method-combination 195 'method-combination) 196 "This method combination is based on the standard method combination, 197 but defines a new method-qualifier, `asdf:around`. `asdf:around` 198 methods will be run *around* any `:around` methods, so that the core 199 protocol may employ around methods and those around methods will not 200 be overridden by around methods added by a system developer.") 201 202 (defgeneric perform (operation component) 203 (:method-combination standard-asdf-method-combination)) 204 (defgeneric operation-done-p (operation component) 205 (:method-combination standard-asdf-method-combination)) 206 (defgeneric explain (operation component) 207 (:method-combination standard-asdf-method-combination)) 208 (defgeneric output-files (operation component) 209 (:method-combination standard-asdf-method-combination)) 210 (defgeneric input-files (operation component) 211 (:method-combination standard-asdf-method-combination)) 356 '(perform-with-restarts perform explain output-files operation-done-p)) 357 358 #+allegro 359 (eval-when (:compile-toplevel :execute) 360 (defparameter *acl-warn-save* 361 (when (boundp 'excl:*warn-on-nested-reader-conditionals*) 362 excl:*warn-on-nested-reader-conditionals*)) 363 (when (boundp 'excl:*warn-on-nested-reader-conditionals*) 364 (setf excl:*warn-on-nested-reader-conditionals* nil))) 365 366 ;;;; ------------------------------------------------------------------------- 367 ;;;; ASDF Interface, in terms of generic functions. 368 369 (defgeneric perform-with-restarts (operation component)) 370 (defgeneric perform (operation component)) 371 (defgeneric operation-done-p (operation component)) 372 (defgeneric explain (operation component)) 373 (defgeneric output-files (operation component)) 374 (defgeneric input-files (operation component)) 375 (defgeneric component-operation-time (operation component)) 212 376 213 377 (defgeneric system-source-file (system) … … 221 385 222 386 (defgeneric component-relative-pathname (component) 223 (:documentation "Extracts the relative pathname applicable for a particular component.")) 387 (:documentation "Returns a pathname for the component argument intended to be 388 interpreted relative to the pathname of that component's parent. 389 Despite the function's name, the return value may be an absolute 390 pathname, because an absolute pathname may be interpreted relative to 391 another pathname in a degenerate way.")) 224 392 225 393 (defgeneric component-property (component property)) … … 229 397 (defgeneric version-satisfies (component version)) 230 398 231 (defgeneric find-component (module name &optional version) 232 (:documentation "Finds the component with name NAME present in the 233 MODULE module; if MODULE is nil, then the component is assumed to be a 234 system.")) 399 (defgeneric find-component (base path) 400 (:documentation "Finds the component with PATH starting from BASE module; 401 if BASE is nil, then the component is assumed to be a system.")) 235 402 236 403 (defgeneric source-file-type (component system)) … … 241 408 the head of the tree")) 242 409 243 (defgeneric component-visited-p (operation component)) 244 245 (defgeneric visit-component (operation component data)) 410 (defgeneric component-visited-p (operation component) 411 (:documentation "Returns the value stored by a call to 412 VISIT-COMPONENT, if that has been called, otherwise NIL. 413 This value stored will be a cons cell, the first element 414 of which is a computed key, so not interesting. The 415 CDR wil be the DATA value stored by VISIT-COMPONENT; recover 416 it as (cdr (component-visited-p op c)). 417 In the current form of ASDF, the DATA value retrieved is 418 effectively a boolean, indicating whether some operations are 419 to be performed in order to do OPERATION X COMPONENT. If the 420 data value is NIL, the combination had been explored, but no 421 operations needed to be performed.")) 422 423 (defgeneric visit-component (operation component data) 424 (:documentation "Record DATA as being associated with OPERATION 425 and COMPONENT. This is a side-effecting function: the association 426 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the 427 OPERATION\). 428 No evidence that DATA is ever interesting, beyond just being 429 non-NIL. Using the data field is probably very risky; if there is 430 already a record for OPERATION X COMPONENT, DATA will be quietly 431 discarded instead of recorded.")) 246 432 247 433 (defgeneric (setf visiting-component) (new-value operation component)) … … 269 455 270 456 (defgeneric traverse (operation component) 271 (:documentation 457 (:documentation 272 458 "Generate and return a plan for performing `operation` on `component`. 273 459 274 460 The plan returned is a list of dotted-pairs. Each pair is the `cons` 275 of ASDF operation object and a `component` object. The pairs will be 461 of ASDF operation object and a `component` object. The pairs will be 276 462 processed in order by `operate`.")) 277 463 278 (defgeneric output-files-using-mappings (source possible-paths path-mappings) 279 (:documentation 280 "Use the variable \\*source-to-target-mappings\\* to find 281 an output path for the source. The algorithm transforms each 282 entry in possible-paths as follows: If there is a mapping 283 whose source starts with the path of possible-path, then 284 replace possible-path with a pathname that starts with the 285 target of the mapping and continues with the rest of 286 possible-path. If no such mapping is found, then use the 287 default mapping. 288 289 If \\*centralize-lisp-binaries\\* is false, then the default 290 mapping is to place the output in a subdirectory of the 291 source. The subdirectory is named using the Lisp 292 implementation \(see 293 implementation-specific-directory-name\). If 294 \\*centralize-lisp-binaries\\* is true, then the default 295 mapping is to place the output in subdirectories of 296 \\*default-toplevel-directory\\* where the subdirectory 297 structure will mirror that of the source.")) 298 299 300 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 301 ;; utility stuff 464 465 ;;;; ------------------------------------------------------------------------- 466 ;;;; General Purpose Utilities 467 468 (defmacro while-collecting ((&rest collectors) &body body) 469 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) 470 (initial-values (mapcar (constantly nil) collectors))) 471 `(let ,(mapcar #'list vars initial-values) 472 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) 473 ,@body 474 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) 302 475 303 476 (defmacro aif (test then &optional else) 304 477 `(let ((it ,test)) (if it ,then ,else))) 305 478 306 (defun pathname- sans-name+type (pathname)479 (defun pathname-directory-pathname (pathname) 307 480 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, 308 and NIL NAME and TYPE components" 309 (make-pathname :name nil :type nil :defaults pathname)) 481 and NIL NAME, TYPE and VERSION components" 482 (make-pathname :name nil :type nil :version nil :defaults pathname)) 483 484 (defun current-directory () 485 (truenamize (pathname-directory-pathname *default-pathname-defaults*))) 486 487 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) 488 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname 489 does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. 490 Also, if either argument is NIL, then the other argument is returned unmodified." 491 (when (null specified) (return-from merge-pathnames* defaults)) 492 (when (null defaults) (return-from merge-pathnames* specified)) 493 (let* ((specified (pathname specified)) 494 (defaults (pathname defaults)) 495 (directory (pathname-directory specified)) 496 (directory (if (stringp directory) `(:absolute ,directory) directory)) 497 (name (or (pathname-name specified) (pathname-name defaults))) 498 (type (or (pathname-type specified) (pathname-type defaults))) 499 (version (or (pathname-version specified) (pathname-version defaults)))) 500 (labels ((ununspecific (x) 501 (if (eq x :unspecific) nil x)) 502 (unspecific-handler (p) 503 (if (typep p 'logical-pathname) #'ununspecific #'identity))) 504 (multiple-value-bind (host device directory unspecific-handler) 505 (#-gcl ecase #+gcl case (first directory) 506 ((nil) 507 (values (pathname-host defaults) 508 (pathname-device defaults) 509 (pathname-directory defaults) 510 (unspecific-handler defaults))) 511 ((:absolute) 512 (values (pathname-host specified) 513 (pathname-device specified) 514 directory 515 (unspecific-handler specified))) 516 ((:relative) 517 (values (pathname-host defaults) 518 (pathname-device defaults) 519 (append (pathname-directory defaults) (cdr directory)) 520 (unspecific-handler defaults))) 521 #+gcl 522 (t 523 (assert (stringp (first directory))) 524 (values (pathname-host defaults) 525 (pathname-device defaults) 526 (append (pathname-directory defaults) directory) 527 (unspecific-handler defaults)))) 528 (make-pathname :host host :device device :directory directory 529 :name (funcall unspecific-handler name) 530 :type (funcall unspecific-handler type) 531 :version (funcall unspecific-handler version)))))) 310 532 311 533 (define-modify-macro appendf (&rest args) 312 append "Append onto list") 534 append "Append onto list") ;; only to be used on short lists. 535 536 (define-modify-macro orf (&rest args) 537 or "or a flag") 313 538 314 539 (defun asdf-message (format-string &rest format-args) … … 316 541 (apply #'format *verbose-out* format-string format-args)) 317 542 318 (defun split-path-string (s &optional force-directory) 543 (defun split-string (string &key max (separator '(#\Space #\Tab))) 544 "Split STRING in components separater by any of the characters in the sequence SEPARATOR, 545 return a list. 546 If MAX is specified, then no more than max(1,MAX) components will be returned, 547 starting the separation from the end, e.g. when called with arguments 548 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." 549 (block nil 550 (let ((list nil) (words 0) (end (length string))) 551 (flet ((separatorp (char) (find char separator)) 552 (done () (return (cons (subseq string 0 end) list)))) 553 (loop 554 :for start = (if (and max (>= words (1- max))) 555 (done) 556 (position-if #'separatorp string :end end :from-end t)) :do 557 (when (null start) 558 (done)) 559 (push (subseq string (1+ start) end) list) 560 (incf words) 561 (setf end start)))))) 562 563 (defun split-name-type (filename) 564 (let ((unspecific 565 ;; Giving :unspecific as argument to make-pathname is not portable. 566 ;; See CLHS make-pathname and 19.2.2.2.3. 567 ;; We only use it on implementations that support it. 568 (or #+(or ccl ecl gcl lispworks sbcl) :unspecific))) 569 (destructuring-bind (name &optional (type unspecific)) 570 (split-string filename :max 2 :separator ".") 571 (if (equal name "") 572 (values filename unspecific) 573 (values name type))))) 574 575 (defun component-name-to-pathname-components (s &optional force-directory) 576 "Splits the path string S, returning three values: 577 A flag that is either :absolute or :relative, indicating 578 how the rest of the values are to be interpreted. 579 A directory path --- a list of strings, suitable for 580 use with MAKE-PATHNAME when prepended with the flag 581 value. 582 A filename with type extension, possibly NIL in the 583 case of a directory pathname. 584 FORCE-DIRECTORY forces S to be interpreted as a directory 585 pathname \(third return value will be NIL, final component 586 of S will be treated as part of the directory path. 587 588 The intention of this function is to support structured component names, 589 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative 590 pathnames." 319 591 (check-type s string) 320 (let* ((components (split s nil"/"))592 (let* ((components (split-string s :separator "/")) 321 593 (last-comp (car (last components)))) 322 594 (multiple-value-bind (relative components) 323 595 (if (equal (first components) "") 324 (values :absolute (cdr components)) 596 (if (and (plusp (length s)) (eql (char s 0) #\/)) 597 (values :absolute (cdr components)) 598 (values :relative nil)) 325 599 (values :relative components)) 326 600 (cond … … 332 606 (values relative (butlast components) last-comp)))))) 333 607 334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 335 ;; classes, condiitons 608 (defun remove-keys (key-names args) 609 (loop :for (name val) :on args :by #'cddr 610 :unless (member (symbol-name name) key-names 611 :key #'symbol-name :test 'equal) 612 :append (list name val))) 613 614 (defun remove-keyword (key args) 615 (loop :for (k v) :on args :by #'cddr 616 :unless (eq k key) 617 :append (list k v))) 618 619 (defun resolve-symlinks (path) 620 #-allegro (truenamize path) 621 #+allegro (excl:pathname-resolve-symbolic-links path)) 622 623 (defun getenv (x) 624 #+abcl 625 (ext:getenv x) 626 #+sbcl 627 (sb-ext:posix-getenv x) 628 #+clozure 629 (ccl::getenv x) 630 #+clisp 631 (ext:getenv x) 632 #+cmu 633 (cdr (assoc (intern x :keyword) ext:*environment-list*)) 634 #+lispworks 635 (lispworks:environment-variable x) 636 #+allegro 637 (sys:getenv x) 638 #+gcl 639 (system:getenv x) 640 #+ecl 641 (si:getenv x)) 642 643 (defun directory-pathname-p (pathname) 644 "Does `pathname` represent a directory? 645 646 A directory-pathname is a pathname _without_ a filename. The three 647 ways that the filename components can be missing are for it to be `nil`, 648 `:unspecific` or the empty string. 649 650 Note that this does _not_ check to see that `pathname` points to an 651 actually-existing directory." 652 (flet ((check-one (x) 653 (member x '(nil :unspecific "") :test 'equal))) 654 (and (check-one (pathname-name pathname)) 655 (check-one (pathname-type pathname)) 656 t))) 657 658 (defun ensure-directory-pathname (pathspec) 659 "Converts the non-wild pathname designator PATHSPEC to directory form." 660 (cond 661 ((stringp pathspec) 662 (ensure-directory-pathname (pathname pathspec))) 663 ((not (pathnamep pathspec)) 664 (error "Invalid pathname designator ~S" pathspec)) 665 ((wild-pathname-p pathspec) 666 (error "Can't reliably convert wild pathnames.")) 667 ((directory-pathname-p pathspec) 668 pathspec) 669 (t 670 (make-pathname :directory (append (or (pathname-directory pathspec) 671 (list :relative)) 672 (list (file-namestring pathspec))) 673 :name nil :type nil :version nil 674 :defaults pathspec)))) 675 676 (defun absolute-pathname-p (pathspec) 677 (eq :absolute (car (pathname-directory (pathname pathspec))))) 678 679 (defun length=n-p (x n) ;is it that (= (length x) n) ? 680 (check-type n (integer 0 *)) 681 (loop 682 :for l = x :then (cdr l) 683 :for i :downfrom n :do 684 (cond 685 ((zerop i) (return (null l))) 686 ((not (consp l)) (return nil))))) 687 688 (defun ends-with (s suffix) 689 (check-type s string) 690 (check-type suffix string) 691 (let ((start (- (length s) (length suffix)))) 692 (and (<= 0 start) 693 (string-equal s suffix :start1 start)))) 694 695 (defun read-file-forms (file) 696 (with-open-file (in file) 697 (loop :with eof = (list nil) 698 :for form = (read in nil eof) 699 :until (eq form eof) 700 :collect form))) 701 702 #-(and (or win32 windows mswindows mingw32) (not cygwin)) 703 (progn 704 #+clisp (defun get-uid () (posix:uid)) 705 #+sbcl (defun get-uid () (sb-unix:unix-getuid)) 706 #+cmu (defun get-uid () (unix:unix-getuid)) 707 #+ecl (ffi:clines "#include <sys/types.h>" "#include <unistd.h>") 708 #+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t)) 709 #+allegro (defun get-uid () (excl.osi:getuid)) 710 #-(or cmu sbcl clisp allegro ecl) 711 (defun get-uid () 712 (let ((uid-string 713 (with-output-to-string (*verbose-out*) 714 (run-shell-command "id -ur")))) 715 (with-input-from-string (stream uid-string) 716 (read-line stream) 717 (handler-case (parse-integer (read-line stream)) 718 (error () (error "Unable to find out user ID"))))))) 719 720 (defun pathname-root (pathname) 721 (make-pathname :host (pathname-host pathname) 722 :device (pathname-device pathname) 723 :directory '(:absolute) 724 :name nil :type nil :version nil)) 725 726 (defun truenamize (p) 727 "Resolve as much of a pathname as possible" 728 (block nil 729 (when (typep p 'logical-pathname) (return p)) 730 (let* ((p (merge-pathnames* p)) 731 (directory (pathname-directory p))) 732 (when (typep p 'logical-pathname) (return p)) 733 (ignore-errors (return (truename p))) 734 (when (stringp directory) 735 (return p)) 736 (when (not (eq :absolute (car directory))) 737 (return p)) 738 (let ((sofar (ignore-errors (truename (pathname-root p))))) 739 (unless sofar (return p)) 740 (flet ((solution (directories) 741 (merge-pathnames* 742 (make-pathname :host nil :device nil 743 :directory `(:relative ,@directories) 744 :name (pathname-name p) 745 :type (pathname-type p) 746 :version (pathname-version p)) 747 sofar))) 748 (loop :for component :in (cdr directory) 749 :for rest :on (cdr directory) 750 :for more = (ignore-errors 751 (truename 752 (merge-pathnames* 753 (make-pathname :directory `(:relative ,component)) 754 sofar))) :do 755 (if more 756 (setf sofar more) 757 (return (solution rest))) 758 :finally 759 (return (solution nil)))))))) 760 761 (defun lispize-pathname (input-file) 762 (make-pathname :type "lisp" :defaults input-file)) 763 764 ;;;; ------------------------------------------------------------------------- 765 ;;;; Classes, Conditions 336 766 337 767 (define-condition system-definition-error (error) () … … 350 780 (apply #'format s (format-control c) (format-arguments c))))) 351 781 782 (define-condition load-system-definition-error (system-definition-error) 783 ((name :initarg :name :reader error-name) 784 (pathname :initarg :pathname :reader error-pathname) 785 (condition :initarg :condition :reader error-condition)) 786 (:report (lambda (c s) 787 (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>" 788 (error-name c) (error-pathname c) (error-condition c))))) 789 352 790 (define-condition circular-dependency (system-definition-error) 353 791 ((components :initarg :components :reader circular-dependency-components))) 354 792 355 793 (define-condition duplicate-names (system-definition-error) 356 ((name :initarg :name :reader duplicate-names-name))) 794 ((name :initarg :name :reader duplicate-names-name)) 795 (:report (lambda (c s) 796 (format s "~@<Error while defining system: multiple components are given same name ~A~@:>" 797 (duplicate-names-name c))))) 357 798 358 799 (define-condition missing-component (system-definition-error) … … 367 808 368 809 (define-condition missing-dependency-of-version (missing-dependency 369 810 missing-component-of-version) 370 811 ()) 371 812 … … 384 825 "Component name: designator for a string composed of portable pathname characters") 385 826 (version :accessor component-version :initarg :version) 386 (in-order-to :initform nil :initarg :in-order-to) 387 ;; XXX crap name 388 (do-first :initform nil :initarg :do-first) 827 (in-order-to :initform nil :initarg :in-order-to 828 :accessor component-in-order-to) 829 ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? 830 (load-dependencies :accessor component-load-dependencies :initform nil) 831 ;; XXX crap name, but it's an official API name! 832 (do-first :initform nil :initarg :do-first 833 :accessor component-do-first) 389 834 ;; methods defined using the "inline" style inside a defsystem form: 390 835 ;; need to store them somewhere so we can delete them when the system … … 395 840 ;; it to default in funky ways if not supplied 396 841 (relative-pathname :initarg :pathname) 397 (operation-times :initform (make-hash-table ) 842 (absolute-pathname) 843 (operation-times :initform (make-hash-table) 398 844 :accessor component-operation-times) 399 845 ;; XXX we should provide some atomic interface for updating the … … 402 848 :initform nil))) 403 849 850 (defun component-find-path (component) 851 (reverse 852 (loop :for c = component :then (component-parent c) 853 :while c :collect (component-name c)))) 854 855 (defmethod print-object ((c component) stream) 856 (print-unreadable-object (c stream :type t :identity nil) 857 (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c)))) 858 859 404 860 ;;;; methods: conditions 405 861 … … 409 865 410 866 (defun sysdef-error (format &rest arguments) 411 (error 'formatted-system-definition-error :format-control 412 867 (error 'formatted-system-definition-error :format-control 868 format :format-arguments arguments)) 413 869 414 870 ;;;; methods: components … … 426 882 (missing-requires c) 427 883 (missing-version c) 428 429 884 (when (missing-parent c) 885 (component-name (missing-parent c))))) 430 886 431 887 (defmethod component-system ((component component)) … … 434 890 component)) 435 891 436 (defmethod print-object ((c component) stream) 437 (print-unreadable-object (c stream :type t :identity t) 438 (ignore-errors 439 (prin1 (component-name c) stream)))) 892 (defvar *default-component-class* 'cl-source-file) 893 894 (defun compute-module-components-by-name (module) 895 (let ((hash (module-components-by-name module))) 896 (clrhash hash) 897 (loop :for c :in (module-components module) 898 :for name = (component-name c) 899 :for previous = (gethash name (module-components-by-name module)) 900 :do 901 (when previous 902 (error 'duplicate-names :name name)) 903 :do (setf (gethash name (module-components-by-name module)) c)) 904 hash)) 440 905 441 906 (defclass module (component) 442 ((components :initform nil :accessor module-components :initarg :components) 443 ;; what to do if we can't satisfy a dependency of one of this module's 444 ;; components. This allows a limited form of conditional processing 445 (if-component-dep-fails :initform :fail 446 :accessor module-if-component-dep-fails 447 :initarg :if-component-dep-fails) 448 (default-component-class :accessor module-default-component-class 449 :initform 'cl-source-file :initarg :default-component-class))) 907 ((components 908 :initform nil 909 :initarg :components 910 :accessor module-components) 911 (components-by-name 912 :initform (make-hash-table :test 'equal) 913 :accessor module-components-by-name) 914 ;; What to do if we can't satisfy a dependency of one of this module's 915 ;; components. This allows a limited form of conditional processing. 916 (if-component-dep-fails 917 :initform :fail 918 :initarg :if-component-dep-fails 919 :accessor module-if-component-dep-fails) 920 (default-component-class 921 :initform *default-component-class* 922 :initarg :default-component-class 923 :accessor module-default-component-class))) 450 924 451 925 (defun component-parent-pathname (component) 452 (aif (component-parent component) 453 (component-pathname it) 454 *default-pathname-defaults*)) 455 456 (defmethod component-relative-pathname ((component module)) 457 (or (slot-value component 'relative-pathname) 458 (multiple-value-bind (relative path) 459 (split-path-string (component-name component) t) 460 (make-pathname 461 :directory `(,relative ,@path) 462 :host (pathname-host (component-parent-pathname component)))))) 926 ;; No default anymore (in particular, no *default-pathname-defaults*). 927 ;; If you force component to have a NULL pathname, you better arrange 928 ;; for any of its children to explicitly provide a proper absolute pathname 929 ;; wherever a pathname is actually wanted. 930 (let ((parent (component-parent component))) 931 (when parent 932 (component-pathname parent)))) 463 933 464 934 (defmethod component-pathname ((component component)) 465 (let ((*default-pathname-defaults* (component-parent-pathname component))) 466 (merge-pathnames (component-relative-pathname component)))) 935 (if (slot-boundp component 'absolute-pathname) 936 (slot-value component 'absolute-pathname) 937 (let ((pathname 938 (merge-pathnames* 939 (component-relative-pathname component) 940 (component-parent-pathname component)))) 941 (unless (or (null pathname) (absolute-pathname-p pathname)) 942 (error "Invalid relative pathname ~S for component ~S" pathname component)) 943 (setf (slot-value component 'absolute-pathname) pathname) 944 pathname))) 467 945 468 946 (defmethod component-property ((c component) property) … … 474 952 (setf (cdr a) new-value) 475 953 (setf (slot-value c 'properties) 476 (acons property new-value (slot-value c 'properties)))))) 954 (acons property new-value (slot-value c 'properties))))) 955 new-value) 477 956 478 957 (defclass system (module) … … 485 964 :accessor system-license :initarg :license) 486 965 (source-file :reader system-source-file :initarg :source-file 487 :writer %set-system-source-file))) 488 489 ;;; version-satisfies 490 491 ;;; with apologies to christophe rhodes ... 492 (defun split (string &optional max (ws '(#\Space #\Tab))) 493 (flet ((is-ws (char) (find char ws))) 494 (nreverse 495 (let ((list nil) (start 0) (words 0) end) 496 (loop 497 (when (and max (>= words (1- max))) 498 (return (cons (subseq string start) list))) 499 (setf end (position-if #'is-ws string :start start)) 500 (push (subseq string start end) list) 501 (incf words) 502 (unless end (return list)) 503 (setf start (1+ end))))))) 966 :writer %set-system-source-file))) 967 968 ;;;; ------------------------------------------------------------------------- 969 ;;;; version-satisfies 504 970 505 971 (defmethod version-satisfies ((c component) version) 506 972 (unless (and version (slot-boundp c 'version)) 507 973 (return-from version-satisfies t)) 974 (version-satisfies (component-version c) version)) 975 976 (defmethod version-satisfies ((cver string) version) 508 977 (let ((x (mapcar #'parse-integer 509 (split (component-version c) nil '(#\.))))978 (split-string cver :separator "."))) 510 979 (y (mapcar #'parse-integer 511 (split version nil '(#\.)))))980 (split-string version :separator ".")))) 512 981 (labels ((bigger (x y) 513 982 (cond ((not y) t) … … 519 988 (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) 520 989 521 ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;522 ;;; finding systems990 ;;;; ------------------------------------------------------------------------- 991 ;;;; Finding systems 523 992 524 993 (defun make-defined-systems-table () 525 994 (make-hash-table :test 'equal)) 526 995 527 (defvar *defined-systems* (make-defined-systems-table)) 996 (defvar *defined-systems* (make-defined-systems-table) 997 "This is a hash table whose keys are strings, being the 998 names of the systems, and whose values are pairs, the first 999 element of which is a universal-time indicating when the 1000 system definition was last updated, and the second element 1001 of which is a system object.") 528 1002 529 1003 (defun coerce-name (name) … … 543 1017 called with an object of type asdf:system." 544 1018 (maphash (lambda (_ datum) 545 546 547 548 549 1019 (declare (ignore _)) 1020 (destructuring-bind (_ . def) datum 1021 (declare (ignore _)) 1022 (funcall fn def))) 1023 *defined-systems*)) 550 1024 551 1025 ;;; for the sake of keeping things reasonably neat, we adopt a 552 1026 ;;; convention that functions in this list are prefixed SYSDEF- 553 1027 554 (def var *system-definition-search-functions*555 '(sysdef-central-registry-search ))1028 (defparameter *system-definition-search-functions* 1029 '(sysdef-central-registry-search sysdef-source-registry-search)) 556 1030 557 1031 (defun system-definition-pathname (system) … … 559 1033 (or 560 1034 (some (lambda (x) (funcall x system-name)) 561 1035 *system-definition-search-functions*) 562 1036 (let ((system-pair (system-registered-p system-name))) 563 1037 (and system-pair 564 (system-source-file (cdr system-pair))))))) 565 566 (defvar *central-registry* 567 `((directory-namestring *default-pathname-defaults*)) 1038 (system-source-file (cdr system-pair))))))) 1039 1040 (defvar *central-registry* nil 568 1041 "A list of 'system directory designators' ASDF uses to find systems. 569 1042 570 A 'system directory designator' is a pathname or a function1043 A 'system directory designator' is a pathname or an expression 571 1044 which evaluates to a pathname. For example: 572 1045 … … 575 1048 #p\"/home/me/cl/systems/\" 576 1049 #p\"/usr/share/common-lisp/systems/\")) 1050 1051 This is for backward compatibilily. 1052 Going forward, we recommend new users should be using the source-registry. 577 1053 ") 578 579 (defun directory-pathname-p (pathname)580 "Does `pathname` represent a directory?581 582 A directory-pathname is a pathname _without_ a filename. The three583 ways that the filename components can be missing are for it to be `nil`,584 `:unspecific` or the empty string.585 586 Note that this does _not_ check to see that `pathname` points to an587 actually-existing directory."588 (flet ((check-one (x)589 (not (null (member x '(nil :unspecific "")590 :test 'equal)))))591 (and (check-one (pathname-name pathname))592 (check-one (pathname-type pathname)))))593 594 #+(or)595 ;;test596 ;;?? move into testsuite sometime soon597 (every (lambda (p)598 (directory-pathname-p p))599 (list600 (make-pathname :name "." :type nil :directory '(:absolute "tmp"))601 (make-pathname :name "." :type "" :directory '(:absolute "tmp"))602 (make-pathname :name nil :type "" :directory '(:absolute "tmp"))603 (make-pathname :name "" :directory '(:absolute "tmp"))604 (make-pathname :type :unspecific :directory '(:absolute "tmp"))605 (make-pathname :name :unspecific :directory '(:absolute "tmp"))606 (make-pathname :name :unspecific :directory '(:absolute "tmp"))607 (make-pathname :type "" :directory '(:absolute "tmp"))608 ))609 610 (defun ensure-directory-pathname (pathname)611 (if (directory-pathname-p pathname)612 pathname613 (make-pathname :defaults pathname614 :directory (append615 (pathname-directory pathname)616 (list (file-namestring pathname)))617 :name nil :type nil :version nil)))618 1054 619 1055 (defun sysdef-central-registry-search (system) 620 1056 (let ((name (coerce-name system)) 621 622 1057 (to-remove nil) 1058 (to-replace nil)) 623 1059 (block nil 624 1060 (unwind-protect 625 (dolist (dir *central-registry*) 626 (let ((defaults (eval dir))) 627 (when defaults 628 (cond ((directory-pathname-p defaults) 629 (let ((file (and defaults 630 (make-pathname 631 :defaults defaults :version :newest 632 :name name :type "asd" :case :local))) 633 #+(and (or win32 windows) (not :clisp)) 634 (shortcut (make-pathname 635 :defaults defaults :version :newest 636 :name name :type "asd.lnk" :case :local))) 637 (if (and file (probe-file file)) 638 (return file)) 639 #+(and (or win32 windows) (not :clisp)) 640 (when (probe-file shortcut) 641 (let ((target (parse-windows-shortcut shortcut))) 642 (when target 643 (return (pathname target))))))) 644 (t 645 (restart-case 646 (let* ((*print-circle* nil) 647 (message 648 (format nil 649 "~@<While searching for system `~a`: `~a` evaluated ~ 650 to `~a` which is not a directory.~@:>" 651 system dir defaults))) 652 (error message)) 653 (remove-entry-from-registry () 654 :report "Remove entry from *central-registry* and continue" 655 (push dir to-remove)) 656 (coerce-entry-to-directory () 657 :report (lambda (s) 658 (format s "Coerce entry to ~a, replace ~a and continue." 659 (ensure-directory-pathname defaults) dir)) 660 (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) 661 ;; cleanup 662 (dolist (dir to-remove) 663 (setf *central-registry* (remove dir *central-registry*))) 664 (dolist (pair to-replace) 665 (let* ((current (car pair)) 666 (new (cdr pair)) 667 (position (position current *central-registry*))) 668 (setf *central-registry* 669 (append (subseq *central-registry* 0 position) 670 (list new) 671 (subseq *central-registry* (1+ position)))))))))) 1061 (dolist (dir *central-registry*) 1062 (let ((defaults (eval dir))) 1063 (when defaults 1064 (cond ((directory-pathname-p defaults) 1065 (let ((file (probe-asd name defaults))) 1066 (when file 1067 (return file)))) 1068 (t 1069 (restart-case 1070 (let* ((*print-circle* nil) 1071 (message 1072 (format nil 1073 "~@<While searching for system `~a`: `~a` evaluated ~ 1074 to `~a` which is not a directory.~@:>" 1075 system dir defaults))) 1076 (error message)) 1077 (remove-entry-from-registry () 1078 :report "Remove entry from *central-registry* and continue" 1079 (push dir to-remove)) 1080 (coerce-entry-to-directory () 1081 :report (lambda (s) 1082 (format s "Coerce entry to ~a, replace ~a and continue." 1083 (ensure-directory-pathname defaults) dir)) 1084 (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) 1085 ;; cleanup 1086 (dolist (dir to-remove) 1087 (setf *central-registry* (remove dir *central-registry*))) 1088 (dolist (pair to-replace) 1089 (let* ((current (car pair)) 1090 (new (cdr pair)) 1091 (position (position current *central-registry*))) 1092 (setf *central-registry* 1093 (append (subseq *central-registry* 0 position) 1094 (list new) 1095 (subseq *central-registry* (1+ position)))))))))) 672 1096 673 1097 (defun make-temporary-package () 674 1098 (flet ((try (counter) 675 1099 (ignore-errors 676 (make-package (format nil "~ a~D" 'asdf counter)1100 (make-package (format nil "~A~D" :asdf counter) 677 1101 :use '(:cl :asdf))))) 678 1102 (do* ((counter 0 (+ counter 1)) 679 1103 (package (try counter) (try counter))) 680 1104 (package package)))) 1105 1106 (defun safe-file-write-date (pathname) 1107 ;; If FILE-WRITE-DATE returns NIL, it's possible that 1108 ;; the user or some other agent has deleted an input file. 1109 ;; Also, generated files will not exist at the time planning is done 1110 ;; and calls operation-done-p which calls safe-file-write-date. 1111 ;; So it is very possible that we can't get a valid file-write-date, 1112 ;; and we can survive and we will continue the planning 1113 ;; as if the file were very old. 1114 ;; (or should we treat the case in a different, special way?) 1115 (or (and pathname (probe-file pathname) (file-write-date pathname)) 1116 (progn 1117 (when pathname 1118 (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." 1119 pathname)) 1120 0))) 681 1121 682 1122 (defun find-system (name &optional (error-p t)) … … 686 1126 (when (and on-disk 687 1127 (or (not in-memory) 688 (< (car in-memory) ( file-write-date on-disk))))1128 (< (car in-memory) (safe-file-write-date on-disk)))) 689 1129 (let ((package (make-temporary-package))) 690 1130 (unwind-protect 691 (let ((*package* package)) 692 (asdf-message 693 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" 694 ;; FIXME: This wants to be (ENOUGH-NAMESTRING 695 ;; ON-DISK), but CMUCL barfs on that. 696 on-disk 697 *package*) 698 (load on-disk)) 1131 (handler-bind 1132 ((error (lambda (condition) 1133 (error 'load-system-definition-error 1134 :name name :pathname on-disk 1135 :condition condition)))) 1136 (let ((*package* package)) 1137 (asdf-message 1138 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" 1139 on-disk *package*) 1140 (load on-disk))) 699 1141 (delete-package package)))) 700 1142 (let ((in-memory (system-registered-p name))) 701 1143 (if in-memory 702 (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) 1144 (progn (when on-disk (setf (car in-memory) 1145 (safe-file-write-date on-disk))) 703 1146 (cdr in-memory)) 704 ( iferror-p (error 'missing-component :requires name))))))1147 (when error-p (error 'missing-component :requires name)))))) 705 1148 706 1149 (defun register-system (name system) … … 710 1153 711 1154 712 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 713 ;;; finding components 714 715 (defmethod find-component ((module module) name &optional version) 716 (if (slot-boundp module 'components) 717 (let ((m (find name (module-components module) 718 :test #'equal :key #'component-name))) 719 (if (and m (version-satisfies m version)) m)))) 720 721 722 ;;; a component with no parent is a system 723 (defmethod find-component ((module (eql nil)) name &optional version) 724 (let ((m (find-system name nil))) 725 (if (and m (version-satisfies m version)) m))) 1155 ;;;; ------------------------------------------------------------------------- 1156 ;;;; Finding components 1157 1158 (defmethod find-component ((base string) path) 1159 (let ((s (find-system base nil))) 1160 (and s (find-component s path)))) 1161 1162 (defmethod find-component ((base symbol) path) 1163 (cond 1164 (base (find-component (coerce-name base) path)) 1165 (path (find-component path nil)) 1166 (t nil))) 1167 1168 (defmethod find-component ((base cons) path) 1169 (find-component (car base) (cons (cdr base) path))) 1170 1171 (defmethod find-component ((module module) (name string)) 1172 (when (slot-boundp module 'components-by-name) 1173 (values (gethash name (module-components-by-name module))))) 1174 1175 (defmethod find-component ((component component) (name symbol)) 1176 (if name 1177 (find-component component (string name)) 1178 component)) 1179 1180 (defmethod find-component ((module module) (name cons)) 1181 (find-component (find-component module (car name)) (cdr name))) 1182 726 1183 727 1184 ;;; component subclasses 728 1185 729 (defclass source-file (component) ()) 730 731 (defclass cl-source-file (source-file) ()) 732 (defclass c-source-file (source-file) ()) 733 (defclass java-source-file (source-file) ()) 1186 (defclass source-file (component) 1187 ((type :accessor source-file-explicit-type :initarg :type :initform nil))) 1188 1189 (defclass cl-source-file (source-file) 1190 ((type :initform "lisp"))) 1191 (defclass c-source-file (source-file) 1192 ((type :initform "c"))) 1193 (defclass java-source-file (source-file) 1194 ((type :initform "java"))) 734 1195 (defclass static-file (source-file) ()) 735 1196 (defclass doc-file (static-file) ()) 736 (defclass html-file (doc-file) ()) 737 738 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp") 739 (defmethod source-file-type ((c c-source-file) (s module)) "c") 740 (defmethod source-file-type ((c java-source-file) (s module)) "java") 741 (defmethod source-file-type ((c html-file) (s module)) "html") 742 (defmethod source-file-type ((c static-file) (s module)) nil) 743 744 (defmethod component-relative-pathname ((component source-file)) 745 (multiple-value-bind (relative path name) 746 (split-path-string (component-name component)) 747 (let ((type (source-file-type component (component-system component))) 748 (relative-pathname (slot-value component 'relative-pathname)) 749 (*default-pathname-defaults* (component-parent-pathname component))) 750 (if relative-pathname 751 (merge-pathnames 752 relative-pathname 753 (if type 754 (make-pathname :name name :type type) 755 name)) 756 (make-pathname :directory `(,relative ,@path) :name name :type type))))) 757 758 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 759 ;;; operations 760 761 ;;; one of these is instantiated whenever (operate ) is called 1197 (defclass html-file (doc-file) 1198 ((type :initform "html"))) 1199 1200 (defmethod source-file-type ((component module) (s module)) 1201 (declare (ignorable component s)) 1202 :directory) 1203 (defmethod source-file-type ((component source-file) (s module)) 1204 (declare (ignorable s)) 1205 (source-file-explicit-type component)) 1206 1207 (defun merge-component-name-type (name &key type defaults) 1208 ;; The defaults are required notably because they provide the default host 1209 ;; to the below make-pathname, which may crucially matter to people using 1210 ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. 1211 ;; NOTE that the host and device slots will be taken from the defaults, 1212 ;; but that should only matter if you either (a) use absolute pathnames, or 1213 ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of 1214 ;; ASDF-UTILITIES:MERGE-PATHNAMES* 1215 (etypecase name 1216 (pathname 1217 name) 1218 (symbol 1219 (merge-component-name-type (string-downcase name) :type type :defaults defaults)) 1220 (string 1221 (multiple-value-bind (relative path filename) 1222 (component-name-to-pathname-components name (eq type :directory)) 1223 (multiple-value-bind (name type) 1224 (cond 1225 ((or (eq type :directory) (null filename)) 1226 (values nil nil)) 1227 (type 1228 (values filename type)) 1229 (t 1230 (split-name-type filename))) 1231 (let* ((defaults (pathname (or defaults *default-pathname-defaults*))) 1232 (host (pathname-host defaults)) 1233 (device (pathname-device defaults))) 1234 (make-pathname :directory `(,relative ,@path) 1235 :name name :type type 1236 :host host :device device))))))) 1237 1238 (defmethod component-relative-pathname ((component component)) 1239 (merge-component-name-type 1240 (or (slot-value component 'relative-pathname) 1241 (component-name component)) 1242 :type (source-file-type component (component-system component)) 1243 :defaults (component-parent-pathname component))) 1244 1245 ;;;; ------------------------------------------------------------------------- 1246 ;;;; Operations 1247 1248 ;;; one of these is instantiated whenever #'operate is called 762 1249 763 1250 (defclass operation () 764 ((forced :initform nil :initarg :force :accessor operation-forced) 1251 ( 1252 ;; as of danb's 2003-03-16 commit e0d02781, :force can be: 1253 ;; T to force the inside of existing system, 1254 ;; but not recurse to other systems we depend on. 1255 ;; :ALL (or any other atom) to force all systems 1256 ;; including other systems we depend on. 1257 ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) 1258 ;; to force systems named in a given list 1259 ;; (but this feature never worked before ASDF 1.700 and is cerror'ed out.) 1260 (forced :initform nil :initarg :force :accessor operation-forced) 765 1261 (original-initargs :initform nil :initarg :original-initargs 766 1262 :accessor operation-original-initargs) 767 (visited-nodes :initform nil:accessor operation-visited-nodes)768 (visiting-nodes :initform nil:accessor operation-visiting-nodes)1263 (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) 1264 (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) 769 1265 (parent :initform nil :initarg :parent :accessor operation-parent))) 770 1266 … … 777 1273 &key force 778 1274 &allow-other-keys) 779 (declare (ignor eslot-names force))1275 (declare (ignorable operation slot-names force)) 780 1276 ;; empty method to disable initarg validity checking 781 )1277 (values)) 782 1278 783 1279 (defun node-for (o c) … … 791 1287 792 1288 (defun make-sub-operation (c o dep-c dep-o) 1289 "C is a component, O is an operation, DEP-C is another 1290 component, and DEP-O, confusingly enough, is an operation 1291 class specifier, not an operation." 793 1292 (let* ((args (copy-list (operation-original-initargs o))) 794 1293 (force-p (getf args :force))) … … 812 1311 (defmethod visit-component ((o operation) (c component) data) 813 1312 (unless (component-visited-p o c) 814 (push (cons (node-for o c) data) 815 (operation-visited-nodes (operation-ancestor o))))) 1313 (setf (gethash (node-for o c) 1314 (operation-visited-nodes (operation-ancestor o))) 1315 (cons t data)))) 816 1316 817 1317 (defmethod component-visited-p ((o operation) (c component)) 818 (assoc (node-for o c) 819 (operation-visited-nodes (operation-ancestor o)) 820 :test 'equal)) 1318 (gethash (node-for o c) 1319 (operation-visited-nodes (operation-ancestor o)))) 821 1320 822 1321 (defmethod (setf visiting-component) (new-value operation component) 823 1322 ;; MCL complains about unused lexical variables 824 (declare (ignorable new-value operation component))) 1323 (declare (ignorable operation component)) 1324 new-value) 825 1325 826 1326 (defmethod (setf visiting-component) (new-value (o operation) (c component)) … … 828 1328 (a (operation-ancestor o))) 829 1329 (if new-value 830 ( pushnew node (operation-visiting-nodes a) :test 'equal)831 ( setf (operation-visiting-nodes a)832 (remove node (operation-visiting-nodes a) :test 'equal)))))1330 (setf (gethash node (operation-visiting-nodes a)) t) 1331 (remhash node (operation-visiting-nodes a))) 1332 new-value)) 833 1333 834 1334 (defmethod component-visiting-p ((o operation) (c component)) 835 1335 (let ((node (node-for o c))) 836 (member node (operation-visiting-nodes (operation-ancestor o)) 837 :test 'equal))) 1336 (gethash node (operation-visiting-nodes (operation-ancestor o))))) 838 1337 839 1338 (defmethod component-depends-on ((op-spec symbol) (c component)) … … 842 1341 (defmethod component-depends-on ((o operation) (c component)) 843 1342 (cdr (assoc (class-name (class-of o)) 844 ( slot-value c 'in-order-to))))1343 (component-in-order-to c)))) 845 1344 846 1345 (defmethod component-self-dependencies ((o operation) (c component)) … … 863 1362 (list (component-pathname c))))) 864 1363 865 (defmethod input-files ((operation operation) (c module)) nil) 1364 (defmethod input-files ((operation operation) (c module)) 1365 (declare (ignorable operation c)) 1366 nil) 1367 1368 (defmethod component-operation-time (o c) 1369 (gethash (type-of o) (component-operation-times c))) 866 1370 867 1371 (defmethod operation-done-p ((o operation) (c component)) 868 (flet ((fwd-or-return-t (file) 869 ;; if FILE-WRITE-DATE returns NIL, it's possible that the 870 ;; user or some other agent has deleted an input file. If 871 ;; that's the case, well, that's not good, but as long as 872 ;; the operation is otherwise considered to be done we 873 ;; could continue and survive. 874 (let ((date (file-write-date file))) 875 (cond 876 (date) 877 (t 878 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~ 879 operation ~S on component ~S as done.~@:>" 880 file o c) 881 (return-from operation-done-p t)))))) 882 (let ((out-files (output-files o c)) 883 (in-files (input-files o c))) 884 (cond ((and (not in-files) (not out-files)) 885 ;; arbitrary decision: an operation that uses nothing to 886 ;; produce nothing probably isn't doing much 887 t) 888 ((not out-files) 889 (let ((op-done 890 (gethash (type-of o) 891 (component-operation-times c)))) 892 (and op-done 893 (>= op-done 894 (apply #'max 895 (mapcar #'fwd-or-return-t in-files)))))) 896 ((not in-files) nil) 897 (t 898 (and 899 (every #'probe-file out-files) 900 (> (apply #'min (mapcar #'file-write-date out-files)) 901 (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) 902 903 ;;; So you look at this code and think "why isn't it a bunch of 904 ;;; methods". And the answer is, because standard method combination 905 ;;; runs :before methods most->least-specific, which is back to front 906 ;;; for our purposes. 907 908 (defmethod traverse ((operation operation) (c component)) 909 (let ((forced nil)) 910 (labels ((%do-one-dep (required-op required-c required-v) 911 (let* ((dep-c (or (find-component 912 (component-parent c) 913 ;; XXX tacky. really we should build the 914 ;; in-order-to slot with canonicalized 915 ;; names instead of coercing this late 916 (coerce-name required-c) required-v) 917 (if required-v 918 (error 'missing-dependency-of-version 919 :required-by c 920 :version required-v 921 :requires required-c) 922 (error 'missing-dependency 923 :required-by c 924 :requires required-c)))) 925 (op (make-sub-operation c operation dep-c required-op))) 926 (traverse op dep-c))) 927 (do-one-dep (required-op required-c required-v) 928 (loop 929 (restart-case 930 (return (%do-one-dep required-op required-c required-v)) 931 (retry () 932 :report (lambda (s) 933 (format s "~@<Retry loading component ~S.~@:>" 934 required-c)) 935 :test 936 (lambda (c) 937 #| 938 (print (list :c1 c (typep c 'missing-dependency))) 939 (when (typep c 'missing-dependency) 940 (print (list :c2 (missing-requires c) required-c 941 (equalp (missing-requires c) 942 required-c)))) 943 |# 944 (and (typep c 'missing-dependency) 945 (equalp (missing-requires c) 946 required-c))))))) 947 (do-dep (op dep) 948 (cond ((eq op 'feature) 949 (or (member (car dep) *features*) 950 (error 'missing-dependency 951 :required-by c 952 :requires (car dep)))) 953 (t 954 (dolist (d dep) 955 (cond ((consp d) 956 (cond ((string-equal 957 (symbol-name (first d)) 958 "VERSION") 959 (appendf 960 forced 961 (do-one-dep op (second d) (third d)))) 962 ((and (string-equal 963 (symbol-name (first d)) 964 "FEATURE") 965 (find (second d) *features* 966 :test 'string-equal)) 967 (appendf 968 forced 969 (do-one-dep op (second d) (third d)))) 970 (t 971 (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature>), or a name" d)))) 972 (t 973 (appendf forced (do-one-dep op d nil))))))))) 1372 (let ((out-files (output-files o c)) 1373 (in-files (input-files o c)) 1374 (op-time (component-operation-time o c))) 1375 (flet ((earliest-out () 1376 (reduce #'min (mapcar #'safe-file-write-date out-files))) 1377 (latest-in () 1378 (reduce #'max (mapcar #'safe-file-write-date in-files)))) 1379 (cond 1380 ((and (not in-files) (not out-files)) 1381 ;; arbitrary decision: an operation that uses nothing to 1382 ;; produce nothing probably isn't doing much. 1383 ;; e.g. operations on systems, modules that have no immediate action, 1384 ;; but are only meaningful through traversed dependencies 1385 t) 1386 ((not out-files) 1387 ;; an operation without output-files is probably meant 1388 ;; for its side-effects in the current image, 1389 ;; assumed to be idem-potent, 1390 ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. 1391 (and op-time (>= op-time (latest-in)))) 1392 ((not in-files) 1393 ;; an operation without output-files and no input-files 1394 ;; is probably meant for its side-effects on the file-system, 1395 ;; assumed to have to be done everytime. 1396 ;; (I don't think there is any such case in ASDF unless extended) 1397 nil) 1398 (t 1399 ;; an operation with both input and output files is assumed 1400 ;; as computing the latter from the former, 1401 ;; assumed to have been done if the latter are all older 1402 ;; than the former. 1403 ;; e.g. COMPILE-OP of some CL-SOURCE-FILE. 1404 ;; We use >= instead of > to play nice with generated files. 1405 ;; This opens a race condition if an input file is changed 1406 ;; after the output is created but within the same second 1407 ;; of filesystem time; but the same race condition exists 1408 ;; whenever the computation from input to output takes more 1409 ;; than one second of filesystem time (or just crosses the 1410 ;; second). So that's cool. 1411 (and 1412 (every #'probe-file in-files) 1413 (every #'probe-file out-files) 1414 (>= (earliest-out) (latest-in)))))))) 1415 1416 1417 1418 ;;; For 1.700 I've done my best to refactor TRAVERSE 1419 ;;; by splitting it up in a bunch of functions, 1420 ;;; so as to improve the collection and use-detection algorithm. --fare 1421 ;;; The protocol is as follows: we pass around operation, dependency, 1422 ;;; bunch of other stuff, and a force argument. Return a force flag. 1423 ;;; The returned flag is T if anything has changed that requires a rebuild. 1424 ;;; The force argument is a list of components that will require a rebuild 1425 ;;; if the flag is T, at which point whoever returns the flag has to 1426 ;;; mark them all as forced, and whoever recurses again can use a NIL list 1427 ;;; as a further argument. 1428 1429 (defvar *forcing* nil 1430 "This dynamically-bound variable is used to force operations in 1431 recursive calls to traverse.") 1432 1433 (defgeneric do-traverse (operation component collect)) 1434 1435 (defun %do-one-dep (operation c collect required-op required-c required-v) 1436 ;; collects a partial plan that results from performing required-op 1437 ;; on required-c, possibly with a required-vERSION 1438 (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c))) 1439 (and d (version-satisfies d required-v) d)) 1440 (if required-v 1441 (error 'missing-dependency-of-version 1442 :required-by c 1443 :version required-v 1444 :requires required-c) 1445 (error 'missing-dependency 1446 :required-by c 1447 :requires required-c)))) 1448 (op (make-sub-operation c operation dep-c required-op))) 1449 (do-traverse op dep-c collect))) 1450 1451 (defun do-one-dep (operation c collect required-op required-c required-v) 1452 ;; this function is a thin, error-handling wrapper around 1453 ;; %do-one-dep. Returns a partial plan per that function. 1454 (loop 1455 (restart-case 1456 (return (%do-one-dep operation c collect 1457 required-op required-c required-v)) 1458 (retry () 1459 :report (lambda (s) 1460 (format s "~@<Retry loading component ~S.~@:>" 1461 required-c)) 1462 :test 1463 (lambda (c) 1464 #| 1465 (print (list :c1 c (typep c 'missing-dependency))) 1466 (when (typep c 'missing-dependency) 1467 (print (list :c2 (missing-requires c) required-c 1468 (equalp (missing-requires c) 1469 required-c)))) 1470 |# 1471 (or (null c) 1472 (and (typep c 'missing-dependency) 1473 (equalp (missing-requires c) 1474 required-c)))))))) 1475 1476 (defun do-dep (operation c collect op dep) 1477 ;; type of arguments uncertain: 1478 ;; op seems to at least potentially be a symbol, rather than an operation 1479 ;; dep is a list of component names 1480 (cond ((eq op 'feature) 1481 (if (member (car dep) *features*) 1482 nil 1483 (error 'missing-dependency 1484 :required-by c 1485 :requires (car dep)))) 1486 (t 1487 (let ((flag nil)) 1488 (flet ((dep (op comp ver) 1489 (when (do-one-dep operation c collect 1490 op comp ver) 1491 (setf flag t)))) 1492 (dolist (d dep) 1493 (if (atom d) 1494 (dep op d nil) 1495 ;; structured dependencies --- this parses keywords 1496 ;; the keywords could be broken out and cleanly (extensibly) 1497 ;; processed by EQL methods 1498 (cond ((eq :version (first d)) 1499 ;; https://bugs.launchpad.net/asdf/+bug/527788 1500 (dep op (second d) (third d))) 1501 ;; This particular subform is not documented and 1502 ;; has always been broken in the past. 1503 ;; Therefore no one uses it, and I'm cerroring it out, 1504 ;; after fixing it 1505 ;; See https://bugs.launchpad.net/asdf/+bug/518467 1506 ((eq :feature (first d)) 1507 (cerror "Continue nonetheless." 1508 "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") 1509 (when (find (second d) *features* :test 'string-equal) 1510 (dep op (third d) nil))) 1511 (t 1512 (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d)))))) 1513 flag)))) 1514 1515 (defun do-collect (collect x) 1516 (funcall collect x)) 1517 1518 (defmethod do-traverse ((operation operation) (c component) collect) 1519 (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? 1520 (labels 1521 ((update-flag (x) 1522 (when x 1523 (setf flag t))) 1524 (dep (op comp) 1525 (update-flag (do-dep operation c collect op comp)))) 1526 ;; Have we been visited yet? If so, just process the result. 974 1527 (aif (component-visited-p operation c) 975 (return-from traverse 976 (if (cdr it) (list (cons 'pruned-op c)) nil))) 1528 (progn 1529 (update-flag (cdr it)) 1530 (return-from do-traverse flag))) 977 1531 ;; dependencies 978 ( if(component-visiting-p operation c)979 1532 (when (component-visiting-p operation c) 1533 (error 'circular-dependency :components (list c))) 980 1534 (setf (visiting-component operation c) t) 981 1535 (unwind-protect 982 (progn 983 (loop for (required-op . deps) in 984 (component-depends-on operation c) 985 do (do-dep required-op deps)) 986 ;; constituent bits 987 (let ((module-ops 988 (when (typep c 'module) 989 (let ((at-least-one nil) 990 (forced nil) 991 (error nil)) 992 (loop for kid in (module-components c) 993 do (handler-case 994 (appendf forced (traverse operation kid )) 995 (missing-dependency (condition) 996 (if (eq (module-if-component-dep-fails c) 997 :fail) 998 (error condition)) 999 (setf error condition)) 1000 (:no-error (c) 1001 (declare (ignore c)) 1002 (setf at-least-one t)))) 1003 (when (and (eq (module-if-component-dep-fails c) 1004 :try-next) 1005 (not at-least-one)) 1006 (error error)) 1007 forced)))) 1008 ;; now the thing itself 1009 (when (or forced module-ops 1010 (not (operation-done-p operation c)) 1011 (let ((f (operation-forced 1012 (operation-ancestor operation)))) 1013 (and f (or (not (consp f)) 1014 (member (component-name 1015 (operation-ancestor operation)) 1016 (mapcar #'coerce-name f) 1017 :test #'string=))))) 1018 (let ((do-first (cdr (assoc (class-name (class-of operation)) 1019 (slot-value c 'do-first))))) 1020 (loop for (required-op . deps) in do-first 1021 do (do-dep required-op deps))) 1022 (setf forced (append (delete 'pruned-op forced :key #'car) 1023 (delete 'pruned-op module-ops :key #'car) 1024 (list (cons operation c))))))) 1025 (setf (visiting-component operation c) nil)) 1026 (visit-component operation c (and forced t)) 1027 forced))) 1028 1536 (progn 1537 ;; first we check and do all the dependencies for the module. 1538 ;; Operations planned in this loop will show up 1539 ;; in the results, and are consumed below. 1540 (let ((*forcing* nil)) 1541 ;; upstream dependencies are never forced to happen just because 1542 ;; the things that depend on them are.... 1543 (loop 1544 :for (required-op . deps) :in (component-depends-on operation c) 1545 :do (dep required-op deps))) 1546 ;; constituent bits 1547 (let ((module-ops 1548 (when (typep c 'module) 1549 (let ((at-least-one nil) 1550 ;; This is set based on the results of the 1551 ;; dependencies and whether we are in the 1552 ;; context of a *forcing* call... 1553 ;; inter-system dependencies do NOT trigger 1554 ;; building components 1555 (*forcing* 1556 (or *forcing* 1557 (and flag (not (typep c 'system))))) 1558 (error nil)) 1559 (while-collecting (internal-collect) 1560 (dolist (kid (module-components c)) 1561 (handler-case 1562 (update-flag 1563 (do-traverse operation kid #'internal-collect)) 1564 (missing-dependency (condition) 1565 (when (eq (module-if-component-dep-fails c) 1566 :fail) 1567 (error condition)) 1568 (setf error condition)) 1569 (:no-error (c) 1570 (declare (ignore c)) 1571 (setf at-least-one t)))) 1572 (when (and (eq (module-if-component-dep-fails c) 1573 :try-next) 1574 (not at-least-one)) 1575 (error error))))))) 1576 (update-flag 1577 (or 1578 *forcing* 1579 (not (operation-done-p operation c)) 1580 ;; For sub-operations, check whether 1581 ;; the original ancestor operation was forced, 1582 ;; or names us amongst an explicit list of things to force... 1583 ;; except that this check doesn't distinguish 1584 ;; between all the things with a given name. Sigh. 1585 ;; BROKEN! 1586 (let ((f (operation-forced 1587 (operation-ancestor operation)))) 1588 (and f (or (not (consp f)) ;; T or :ALL 1589 (and (typep c 'system) ;; list of names of systems to force 1590 (member (component-name c) f 1591 :test #'string=))))))) 1592 (when flag 1593 (let ((do-first (cdr (assoc (class-name (class-of operation)) 1594 (component-do-first c))))) 1595 (loop :for (required-op . deps) :in do-first 1596 :do (do-dep operation c collect required-op deps))) 1597 (do-collect collect (vector module-ops)) 1598 (do-collect collect (cons operation c))))) 1599 (setf (visiting-component operation c) nil))) 1600 (visit-component operation c flag) 1601 flag)) 1602 1603 (defmethod traverse ((operation operation) (c component)) 1604 ;; cerror'ing a feature that seems to have NEVER EVER worked 1605 ;; ever since danb created it in his 2003-03-16 commit e0d02781. 1606 ;; It was both fixed and disabled in the 1.700 rewrite. 1607 (when (consp (operation-forced operation)) 1608 (cerror "Continue nonetheless." 1609 "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") 1610 (setf (operation-forced operation) 1611 (mapcar #'coerce-name (operation-forced operation)))) 1612 (flatten-tree 1613 (while-collecting (collect) 1614 (do-traverse operation c #'collect)))) 1615 1616 (defun flatten-tree (l) 1617 ;; You collected things into a list. 1618 ;; Most elements are just things to collect again. 1619 ;; A (simple-vector 1) indicate that you should recurse into its contents. 1620 ;; This way, in two passes (rather than N being the depth of the tree), 1621 ;; you can collect things with marginally constant-time append, 1622 ;; achieving linear time collection instead of quadratic time. 1623 (while-collecting (c) 1624 (labels ((r (x) 1625 (if (typep x '(simple-vector 1)) 1626 (r* (svref x 0)) 1627 (c x))) 1628 (r* (l) 1629 (dolist (x l) (r x)))) 1630 (r* l)))) 1029 1631 1030 1632 (defmethod perform ((operation operation) (c source-file)) … … 1035 1637 1036 1638 (defmethod perform ((operation operation) (c module)) 1639 (declare (ignorable operation c)) 1037 1640 nil) 1038 1641 … … 1040 1643 (asdf-message "~&;;; ~A on ~A~%" operation component)) 1041 1644 1042 ;;; compile-op 1645 ;;;; ------------------------------------------------------------------------- 1646 ;;;; compile-op 1043 1647 1044 1648 (defclass compile-op (operation) … … 1047 1651 :initform *compile-file-warnings-behaviour*) 1048 1652 (on-failure :initarg :on-failure :accessor operation-on-failure 1049 :initform *compile-file-failure-behaviour*))) 1653 :initform *compile-file-failure-behaviour*) 1654 (flags :initarg :flags :accessor compile-op-flags 1655 :initform #-ecl nil #+ecl '(:system-p t)))) 1050 1656 1051 1657 (defmethod perform :before ((operation compile-op) (c source-file)) 1052 1658 (map nil #'ensure-directories-exist (output-files operation c))) 1659 1660 #+ecl 1661 (defmethod perform :after ((o compile-op) (c cl-source-file)) 1662 ;; Note how we use OUTPUT-FILES to find the binary locations 1663 ;; This allows the user to override the names. 1664 (let* ((input (output-files o c)) 1665 (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl))) 1666 (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=)))) 1053 1667 1054 1668 (defmethod perform :after ((operation operation) (c component)) … … 1063 1677 (output-file (car (output-files operation c)))) 1064 1678 (multiple-value-bind (output warnings-p failure-p) 1065 (compile-file source-file :output-file output-file) 1679 (apply #'compile-file source-file :output-file output-file 1680 (compile-op-flags operation)) 1066 1681 (when warnings-p 1067 1682 (case (operation-on-warnings operation) … … 1082 1697 1083 1698 (defmethod output-files ((operation compile-op) (c cl-source-file)) 1084 #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) 1085 #+:broken-fasl-loader (list (component-pathname c))) 1699 (declare (ignorable operation)) 1700 (let ((p (lispize-pathname (component-pathname c)))) 1701 #-:broken-fasl-loader 1702 (list #-ecl (compile-file-pathname p) 1703 #+ecl (compile-file-pathname p :type :object) 1704 #+ecl (compile-file-pathname p :type :fasl)) 1705 #+:broken-fasl-loader (list p))) 1086 1706 1087 1707 (defmethod perform ((operation compile-op) (c static-file)) 1708 (declare (ignorable operation c)) 1088 1709 nil) 1089 1710 1090 1711 (defmethod output-files ((operation compile-op) (c static-file)) 1712 (declare (ignorable operation c)) 1091 1713 nil) 1092 1714 1093 (defmethod input-files ((op compile-op) (c static-file)) 1715 (defmethod input-files ((operation compile-op) (c static-file)) 1716 (declare (ignorable operation c)) 1094 1717 nil) 1095 1718 1096 1719 1097 ;;; load-op 1720 ;;;; ------------------------------------------------------------------------- 1721 ;;;; load-op 1098 1722 1099 1723 (defclass basic-load-op (operation) ()) … … 1102 1726 1103 1727 (defmethod perform ((o load-op) (c cl-source-file)) 1104 (mapcar #'load (input-files o c))) 1105 1106 (defmethod perform around ((o load-op) (c cl-source-file)) 1107 (let ((state :initial)) 1108 (loop until (or (eq state :success) 1109 (eq state :failure)) do 1110 (case state 1111 (:recompiled 1112 (setf state :failure) 1113 (call-next-method) 1114 (setf state :success)) 1115 (:failed-load 1116 (setf state :recompiled) 1117 (perform (make-instance 'asdf:compile-op) c)) 1118 (t 1119 (with-simple-restart 1120 (try-recompiling "Recompile ~a and try loading it again" 1121 (component-name c)) 1122 (setf state :failed-load) 1123 (call-next-method) 1124 (setf state :success))))))) 1125 1126 (defmethod perform around ((o compile-op) (c cl-source-file)) 1127 (let ((state :initial)) 1128 (loop until (or (eq state :success) 1129 (eq state :failure)) do 1130 (case state 1131 (:recompiled 1132 (setf state :failure) 1133 (call-next-method) 1134 (setf state :success)) 1135 (:failed-compile 1136 (setf state :recompiled) 1137 (perform (make-instance 'asdf:compile-op) c)) 1138 (t 1139 (with-simple-restart 1140 (try-recompiling "Try recompiling ~a" 1141 (component-name c)) 1142 (setf state :failed-compile) 1143 (call-next-method) 1144 (setf state :success))))))) 1728 #-ecl (mapcar #'load (input-files o c)) 1729 #+ecl (loop :for i :in (input-files o c) 1730 :unless (string= (pathname-type i) "fas") 1731 :collect (let ((output (compile-file-pathname (lispize-pathname i)))) 1732 (load output)))) 1733 1734 (defmethod perform-with-restarts (operation component) 1735 (perform operation component)) 1736 1737 (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) 1738 (declare (ignorable o)) 1739 (loop :with state = :initial 1740 :until (or (eq state :success) 1741 (eq state :failure)) :do 1742 (case state 1743 (:recompiled 1744 (setf state :failure) 1745 (call-next-method) 1746 (setf state :success)) 1747 (:failed-load 1748 (setf state :recompiled) 1749 (perform (make-instance 'compile-op) c)) 1750 (t 1751 (with-simple-restart 1752 (try-recompiling "Recompile ~a and try loading it again" 1753 (component-name c)) 1754 (setf state :failed-load) 1755 (call-next-method) 1756 (setf state :success)))))) 1757 1758 (defmethod perform-with-restarts ((o compile-op) (c cl-source-file)) 1759 (loop :with state = :initial 1760 :until (or (eq state :success) 1761 (eq state :failure)) :do 1762 (case state 1763 (:recompiled 1764 (setf state :failure) 1765 (call-next-method) 1766 (setf state :success)) 1767 (:failed-compile 1768 (setf state :recompiled) 1769 (perform-with-restarts o c)) 1770 (t 1771 (with-simple-restart 1772 (try-recompiling "Try recompiling ~a" 1773 (component-name c)) 1774 (setf state :failed-compile) 1775 (call-next-method) 1776 (setf state :success)))))) 1145 1777 1146 1778 (defmethod perform ((operation load-op) (c static-file)) 1779 (declare (ignorable operation c)) 1147 1780 nil) 1148 1781 1149 1782 (defmethod operation-done-p ((operation load-op) (c static-file)) 1783 (declare (ignorable operation c)) 1150 1784 t) 1151 1785 1152 (defmethod output-files ((o operation) (c component)) 1786 (defmethod output-files ((operation operation) (c component)) 1787 (declare (ignorable operation c)) 1153 1788 nil) 1154 1789 1155 1790 (defmethod component-depends-on ((operation load-op) (c component)) 1791 (declare (ignorable operation)) 1156 1792 (cons (list 'compile-op (component-name c)) 1157 1793 (call-next-method))) 1158 1794 1159 ;;; load-source-op 1795 ;;;; ------------------------------------------------------------------------- 1796 ;;;; load-source-op 1160 1797 1161 1798 (defclass load-source-op (basic-load-op) ()) 1162 1799 1163 1800 (defmethod perform ((o load-source-op) (c cl-source-file)) 1801 (declare (ignorable o)) 1164 1802 (let ((source (component-pathname c))) 1165 1803 (setf (component-property c 'last-loaded-as-source) … … 1168 1806 1169 1807 (defmethod perform ((operation load-source-op) (c static-file)) 1808 (declare (ignorable operation c)) 1170 1809 nil) 1171 1810 1172 1811 (defmethod output-files ((operation load-source-op) (c component)) 1812 (declare (ignorable operation c)) 1173 1813 nil) 1174 1814 1175 1815 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. 1176 1816 (defmethod component-depends-on ((o load-source-op) (c component)) 1817 (declare (ignorable o)) 1177 1818 (let ((what-would-load-op-do (cdr (assoc 'load-op 1178 ( slot-value c 'in-order-to)))))1819 (component-in-order-to c))))) 1179 1820 (mapcar (lambda (dep) 1180 1821 (if (eq (car dep) 'load-op) … … 1184 1825 1185 1826 (defmethod operation-done-p ((o load-source-op) (c source-file)) 1827 (declare (ignorable o)) 1186 1828 (if (or (not (component-property c 'last-loaded-as-source)) 1187 (> ( file-write-date (component-pathname c))1829 (> (safe-file-write-date (component-pathname c)) 1188 1830 (component-property c 'last-loaded-as-source))) 1189 1831 nil t)) 1190 1832 1833 1834 ;;;; ------------------------------------------------------------------------- 1835 ;;;; test-op 1836 1191 1837 (defclass test-op (operation) ()) 1192 1838 1193 1839 (defmethod perform ((operation test-op) (c component)) 1840 (declare (ignorable operation c)) 1194 1841 nil) 1195 1842 1196 1843 (defmethod operation-done-p ((operation test-op) (c system)) 1197 1844 "Testing a system is _never_ done." 1845 (declare (ignorable operation c)) 1198 1846 nil) 1199 1847 1200 1848 (defmethod component-depends-on :around ((o test-op) (c system)) 1849 (declare (ignorable o)) 1201 1850 (cons `(load-op ,(component-name c)) (call-next-method))) 1202 1851 1203 1852 1204 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1205 ;;; invoking operations 1206 1207 (defun operate (operation-class system &rest args &key (verbose t) version force 1208 &allow-other-keys) 1853 ;;;; ------------------------------------------------------------------------- 1854 ;;;; Invoking Operations 1855 1856 (defgeneric operate (operation-class system &key &allow-other-keys)) 1857 1858 (defmethod operate (operation-class system &rest args 1859 &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force 1860 &allow-other-keys) 1209 1861 (declare (ignore force)) 1210 1862 (let* ((*package* *package*) … … 1213 1865 :original-initargs args 1214 1866 args)) 1215 (*verbose-out* (if verbose*standard-output* (make-broadcast-stream)))1867 (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) 1216 1868 (system (if (typep system 'component) system (find-system system)))) 1217 1869 (unless (version-satisfies system version) … … 1219 1871 (let ((steps (traverse op system))) 1220 1872 (with-compilation-unit () 1221 (loop for (op . component) in steps do 1222 (loop 1223 (restart-case 1224 (progn (perform op component) 1225 (return)) 1226 (retry () 1227 :report 1228 (lambda (s) 1229 (format s "~@<Retry performing ~S on ~S.~@:>" 1230 op component))) 1231 (accept () 1232 :report 1233 (lambda (s) 1234 (format s "~@<Continue, treating ~S on ~S as ~ 1873 (loop :for (op . component) :in steps :do 1874 (loop 1875 (restart-case 1876 (progn 1877 (perform-with-restarts op component) 1878 (return)) 1879 (retry () 1880 :report 1881 (lambda (s) 1882 (format s "~@<Retry performing ~S on ~S.~@:>" 1883 op component))) 1884 (accept () 1885 :report 1886 (lambda (s) 1887 (format s "~@<Continue, treating ~S on ~S as ~ 1235 1888 having been successful.~@:>" 1236 1237 1238 1239 1240 1889 op component)) 1890 (setf (gethash (type-of op) 1891 (component-operation-times component)) 1892 (get-universal-time)) 1893 (return))))))) 1241 1894 op)) 1242 1895 1243 (defun oos (operation-class system &rest args &key force (verbose t)version1244 1896 (defun oos (operation-class system &rest args &key force verbose version 1897 &allow-other-keys) 1245 1898 (declare (ignore force verbose version)) 1246 1899 (apply #'operate operation-class system args)) … … 1265 1918 ")) 1266 1919 (setf (documentation 'oos 'function) 1267 1268 "Short for _operate on system_ and an alias for the [operate][]function. ~&~&~a"1269 1920 (format nil 1921 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" 1922 operate-docstring)) 1270 1923 (setf (documentation 'operate 'function) 1271 operate-docstring)) 1272 1273 (defun load-system (system &rest args &key force (verbose t) version) 1274 "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details." 1924 operate-docstring)) 1925 1926 (defun load-system (system &rest args &key force verbose version 1927 &allow-other-keys) 1928 "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for 1929 details." 1275 1930 (declare (ignore force verbose version)) 1276 1931 (apply #'operate 'load-op system args)) 1277 1932 1278 (defun compile-system (system &rest args &key force (verbose t) version) 1279 "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details." 1933 (defun compile-system (system &rest args &key force verbose version 1934 &allow-other-keys) 1935 "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE 1936 for details." 1280 1937 (declare (ignore force verbose version)) 1281 1938 (apply #'operate 'compile-op system args)) 1282 1939 1283 (defun test-system (system &rest args &key force (verbose t) version) 1284 "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details." 1940 (defun test-system (system &rest args &key force verbose version 1941 &allow-other-keys) 1942 "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for 1943 details." 1285 1944 (declare (ignore force verbose version)) 1286 1945 (apply #'operate 'test-op system args)) 1287 1946 1288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1289 ;;; syntax 1290 1291 (defun remove-keyword (key arglist) 1292 (labels ((aux (key arglist) 1293 (cond ((null arglist) nil) 1294 ((eq key (car arglist)) (cddr arglist)) 1295 (t (cons (car arglist) (cons (cadr arglist) 1296 (remove-keyword 1297 key (cddr arglist)))))))) 1298 (aux key arglist))) 1299 1300 (defun resolve-symlinks (path) 1301 #-allegro (truename path) 1302 #+allegro (excl:pathname-resolve-symbolic-links path) 1303 ) 1947 ;;;; ------------------------------------------------------------------------- 1948 ;;;; Defsystem 1304 1949 1305 1950 (defun determine-system-pathname (pathname pathname-supplied-p) 1306 1951 ;; called from the defsystem macro. 1307 1952 ;; the pathname of a system is either 1308 ;; 1. the one supplied, 1953 ;; 1. the one supplied, 1309 1954 ;; 2. derived from the *load-truename* (see below), or 1310 1955 ;; 3. taken from *default-pathname-defaults* … … 1314 1959 ;; *load-pathname* instead of *load-truename* since in some 1315 1960 ;; implementations, the latter has *already resolved it. 1316 (or (and pathname-supplied-p pathname) 1317 (when *load-truename* 1318 (pathname-sans-name+type 1319 (if *resolve-symlinks* 1320 (resolve-symlinks *load-truename*) 1321 *load-pathname*))) 1322 *default-pathname-defaults*)) 1961 (let ((file-pathname 1962 (when (or *load-pathname* *compile-file-pathname*) 1963 (pathname-directory-pathname 1964 (if *resolve-symlinks* 1965 (resolve-symlinks (or *load-truename* *compile-file-truename*)) 1966 *load-pathname*))))) 1967 (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname)) 1968 file-pathname 1969 (current-directory)))) 1323 1970 1324 1971 (defmacro defsystem (name &body options) 1325 1972 (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) 1326 &allow-other-keys)1973 defsystem-depends-on &allow-other-keys) 1327 1974 options 1328 (let ((component-options (remove-key word :classoptions)))1975 (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) 1329 1976 `(progn 1330 1977 ;; system must be registered before we parse the body, otherwise 1331 1978 ;; we recur when trying to find an existing system of the same name 1332 1979 ;; to reuse options (e.g. pathname) from 1980 ,@(loop :for system :in defsystem-depends-on 1981 :collect `(load-system ,system)) 1333 1982 (let ((s (system-registered-p ',name))) 1334 1983 (cond ((and s (eq (type-of (cdr s)) ',class)) … … 1339 1988 (register-system (quote ,name) 1340 1989 (make-instance ',class :name ',name)))) 1341 (%set-system-source-file *load-truename* 1342 (cdr (system-registered-p ',name)))) 1343 (parse-component-form 1344 nil (apply 1345 #'list 1346 :module (coerce-name ',name) 1347 :pathname 1348 ,(determine-system-pathname pathname pathname-arg-p) 1349 ',component-options)))))) 1990 (%set-system-source-file *load-truename* 1991 (cdr (system-registered-p ',name)))) 1992 (parse-component-form 1993 nil (list* 1994 :module (coerce-name ',name) 1995 :pathname 1996 ,(determine-system-pathname pathname pathname-arg-p) 1997 ',component-options)))))) 1350 1998 1351 1999 … … 1394 2042 1395 2043 1396 (defun remove-keys (key-names args) 1397 (loop for ( name val ) on args by #'cddr 1398 unless (member (symbol-name name) key-names 1399 :key #'symbol-name :test 'equal) 1400 append (list name val))) 1401 1402 (defvar *serial-depends-on*) 2044 (defvar *serial-depends-on* nil) 1403 2045 1404 2046 (defun sysdef-error-component (msg type name value) 1405 2047 (sysdef-error (concatenate 'string msg 1406 "~&The value specified for ~(~A~) ~A is ~ W")2048 "~&The value specified for ~(~A~) ~A is ~S") 1407 2049 type name value)) 1408 2050 1409 (defun check-component-input (type name weakly-depends-on 1410 2051 (defun check-component-input (type name weakly-depends-on 2052 depends-on components in-order-to) 1411 2053 "A partial test of the values of a component." 1412 2054 (unless (listp depends-on) … … 1424 2066 1425 2067 (defun %remove-component-inline-methods (component) 1426 ( loop for name in +asdf-methods+1427 do (map 'nil1428 1429 ;; methods will not be for this particular gf n1430 1431 1432 1433 2068 (dolist (name +asdf-methods+) 2069 (map () 2070 ;; this is inefficient as most of the stored 2071 ;; methods will not be for this particular gf 2072 ;; But this is hardly performance-critical 2073 (lambda (m) 2074 (remove-method (symbol-function name) m)) 2075 (component-inline-methods component))) 1434 2076 ;; clear methods, then add the new ones 1435 2077 (setf (component-inline-methods component) nil)) 1436 2078 1437 2079 (defun %define-component-inline-methods (ret rest) 1438 ( loop for name in +asdf-methods+ do1439 1440 (loop for data = restthen (cddr data)1441 1442 1443 1444 when (eq key keyword)do1445 1446 1447 1448 1449 2080 (dolist (name +asdf-methods+) 2081 (let ((keyword (intern (symbol-name name) :keyword))) 2082 (loop :for data = rest :then (cddr data) 2083 :for key = (first data) 2084 :for value = (second data) 2085 :while data 2086 :when (eq key keyword) :do 2087 (destructuring-bind (op qual (o c) &body body) value 2088 (pushnew 2089 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) 2090 ,@body)) 2091 (component-inline-methods ret))))))) 1450 2092 1451 2093 (defun %refresh-component-inline-methods (component rest) 1452 2094 (%remove-component-inline-methods component) 1453 2095 (%define-component-inline-methods component rest)) 1454 2096 1455 2097 (defun parse-component-form (parent options) 1456 1457 2098 (destructuring-bind 1458 2099 (type name &rest rest &key … … 1486 2127 (make-instance (class-for-type parent type))))) 1487 2128 (when weakly-depends-on 1488 (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) 1489 (when (boundp '*serial-depends-on*) 1490 (setf depends-on 1491 (concatenate 'list *serial-depends-on* depends-on))) 2129 (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) 2130 (when *serial-depends-on* 2131 (push *serial-depends-on* depends-on)) 1492 2132 (apply #'reinitialize-instance ret 1493 2133 :name (coerce-name name) … … 1495 2135 :parent parent 1496 2136 other-args) 2137 (component-pathname ret) ; eagerly compute the absolute pathname 1497 2138 (when (typep ret 'module) 1498 2139 (setf (module-default-component-class ret) … … 1502 2143 (let ((*serial-depends-on* nil)) 1503 2144 (setf (module-components ret) 1504 (loop for c-form in components 1505 for c = (parse-component-form ret c-form) 1506 collect c 1507 if serial 1508 do (push (component-name c) *serial-depends-on*)))) 1509 1510 ;; check for duplicate names 1511 (let ((name-hash (make-hash-table :test #'equal))) 1512 (loop for c in (module-components ret) 1513 do 1514 (if (gethash (component-name c) 1515 name-hash) 1516 (error 'duplicate-names 1517 :name (component-name c)) 1518 (setf (gethash (component-name c) 1519 name-hash) 1520 t))))) 1521 1522 (setf (slot-value ret 'in-order-to) 2145 (loop 2146 :for c-form :in components 2147 :for c = (parse-component-form ret c-form) 2148 :for name = (component-name c) 2149 :collect c 2150 :when serial :do (setf *serial-depends-on* name)))) 2151 (compute-module-components-by-name ret)) 2152 2153 (setf (component-load-dependencies ret) depends-on) ;; Used by POIU 2154 2155 (setf (component-in-order-to ret) 1523 2156 (union-of-dependencies 1524 2157 in-order-to 1525 2158 `((compile-op (compile-op ,@depends-on)) 1526 (load-op (load-op ,@depends-on)))) 1527 (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))2159 (load-op (load-op ,@depends-on))))) 2160 (setf (component-do-first ret) `((compile-op (load-op ,@depends-on)))) 1528 2161 1529 2162 (%refresh-component-inline-methods ret rest) 1530 1531 2163 ret))) 1532 2164 1533 ;;; optional extras 1534 1535 ;;; run-shell-command functions for other lisp implementations will be 1536 ;;; gratefully accepted, if they do the same thing. If the docstring 1537 ;;; is ambiguous, send a bug report 2165 ;;;; --------------------------------------------------------------------------- 2166 ;;;; run-shell-command 2167 ;;;; 2168 ;;;; run-shell-command functions for other lisp implementations will be 2169 ;;;; gratefully accepted, if they do the same thing. 2170 ;;;; If the docstring is ambiguous, send a bug report. 2171 ;;;; 2172 ;;;; We probably should move this functionality to its own system and deprecate 2173 ;;;; use of it from the asdf package. However, this would break unspecified 2174 ;;;; existing software, so until a clear alternative exists, we can't deprecate 2175 ;;;; it, and even after it's been deprecated, we will support it for a few 2176 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 1538 2177 1539 2178 (defun run-shell-command (control-string &rest args) … … 1543 2182 (let ((command (apply #'format nil control-string args))) 1544 2183 (asdf-message "; $ ~A~%" command) 2184 2185 #+abcl 2186 (ext:run-shell-command command :output *verbose-out*) 2187 2188 #+allegro 2189 ;; will this fail if command has embedded quotes - it seems to work 2190 (multiple-value-bind (stdout stderr exit-code) 2191 (excl.osi:command-output 2192 (format nil "~a -c \"~a\"" 2193 #+mswindows "sh" #-mswindows "/bin/sh" command) 2194 :input nil :whole nil 2195 #+mswindows :show-window #+mswindows :hide) 2196 (format *verbose-out* "~{~&; ~a~%~}~%" stderr) 2197 (format *verbose-out* "~{~&; ~a~%~}~%" stdout) 2198 exit-code) 2199 2200 #+clisp ;XXX not exactly *verbose-out*, I know 2201 (ext:run-shell-command command :output :terminal :wait t) 2202 2203 #+clozure 2204 (nth-value 1 2205 (ccl:external-process-status 2206 (ccl:run-program "/bin/sh" (list "-c" command) 2207 :input nil :output *verbose-out* 2208 :wait t))) 2209 2210 #+ecl ;; courtesy of Juan Jose Garcia Ripoll 2211 (si:system command) 2212 2213 #+gcl 2214 (lisp:system command) 2215 2216 #+lispworks 2217 (system:call-system-showing-output 2218 command 2219 :shell-type "/bin/sh" 2220 :show-cmd nil 2221 :prefix "" 2222 :output-stream *verbose-out*) 2223 1545 2224 #+sbcl 1546 2225 (sb-ext:process-exit-code 1547 2226 (apply #'sb-ext:run-program 1548 1549 1550 1551 2227 #+win32 "sh" #-win32 "/bin/sh" 2228 (list "-c" command) 2229 :input nil :output *verbose-out* 2230 #+win32 '(:search t) #-win32 nil)) 1552 2231 1553 2232 #+(or cmu scl) … … 1558 2237 :input nil :output *verbose-out*)) 1559 2238 1560 #+allegro 1561 ;; will this fail if command has embedded quotes - it seems to work 1562 (multiple-value-bind (stdout stderr exit-code) 1563 (excl.osi:command-output 1564 (format nil "~a -c \"~a\"" 1565 #+mswindows "sh" #-mswindows "/bin/sh" command) 1566 :input nil :whole nil 1567 #+mswindows :show-window #+mswindows :hide) 1568 (format *verbose-out* "~{~&; ~a~%~}~%" stderr) 1569 (format *verbose-out* "~{~&; ~a~%~}~%" stdout) 1570 exit-code) 1571 1572 #+lispworks 1573 (system:call-system-showing-output 1574 command 1575 :shell-type "/bin/sh" 1576 :output-stream *verbose-out*) 1577 1578 #+clisp ;XXX not exactly *verbose-out*, I know 1579 (ext:run-shell-command command :output :terminal :wait t) 1580 1581 #+openmcl 1582 (nth-value 1 1583 (ccl:external-process-status 1584 (ccl:run-program "/bin/sh" (list "-c" command) 1585 :input nil :output *verbose-out* 1586 :wait t))) 1587 1588 #+ecl ;; courtesy of Juan Jose Garcia Ripoll 1589 (si:system command) 1590 1591 #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) 1592 (error "RUN-SHELL-PROGRAM not implemented for this Lisp") 1593 )) 1594 1595 (defmethod system-source-file ((system-name t)) 2239 #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) 2240 (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) 2241 2242 ;;;; --------------------------------------------------------------------------- 2243 ;;;; system-relative-pathname 2244 2245 (defmethod system-source-file ((system-name string)) 1596 2246 (system-source-file (find-system system-name))) 1597 1598 (defun system-source-directory (system-name) 1599 (make-pathname :name nil 2247 (defmethod system-source-file ((system-name symbol)) 2248 (system-source-file (find-system system-name))) 2249 2250 (defun system-source-directory (system-designator) 2251 "Return a pathname object corresponding to the 2252 directory in which the system specification (.asd file) is 2253 located." 2254 (make-pathname :name nil 1600 2255 :type nil 1601 :defaults (system-source-file system-name))) 1602 1603 (defun system-relative-pathname (system pathname &key name type) 1604 ;; you're not allowed to muck with the return value of pathname-X 1605 (let ((directory (copy-list (pathname-directory pathname)))) 1606 (when (eq (car directory) :absolute) 1607 (setf (car directory) :relative)) 1608 (merge-pathnames 1609 (make-pathname :name (or name (pathname-name pathname)) 1610 :type (or type (pathname-type pathname)) 1611 :directory directory) 1612 (system-source-directory system)))) 2256 :defaults (system-source-file system-designator))) 2257 2258 (defun relativize-directory (directory) 2259 (cond 2260 ((stringp directory) 2261 (list :relative directory)) 2262 ((eq (car directory) :absolute) 2263 (cons :relative (cdr directory))) 2264 (t 2265 directory))) 2266 2267 (defun relativize-pathname-directory (pathspec) 2268 (let ((p (pathname pathspec))) 2269 (make-pathname 2270 :directory (relativize-directory (pathname-directory p)) 2271 :defaults p))) 2272 2273 (defun system-relative-pathname (system name &key type) 2274 (merge-pathnames* 2275 (merge-component-name-type name :type type) 2276 (system-source-directory system))) 2277 1613 2278 1614 2279 ;;; --------------------------------------------------------------------------- 1615 ;;; asdf-binary-locations2280 ;;; implementation-identifier 1616 2281 ;;; 1617 ;;; this bit of code was stolen from Bjorn Lindberg and then it grew! 1618 ;;; see http://www.cliki.net/asdf%20binary%20locations 1619 ;;; and http://groups.google.com/group/comp.lang.lisp/msg/bd5ea9d2008ab9fd 1620 ;;; --------------------------------------------------------------------------- 1621 ;;; Portions of this code were once from SWANK / SLIME 1622 1623 (defparameter *centralize-lisp-binaries* 1624 nil " 1625 If true, compiled lisp files without an explicit mapping (see 1626 \\*source-to-target-mappings\\*) will be placed in subdirectories of 1627 \\*default-toplevel-directory\\*. If false, then compiled lisp files 1628 without an explicitly mapping will be placed in subdirectories of 1629 their sources.") 1630 1631 (defparameter *enable-asdf-binary-locations* nil 1632 " 1633 If true, then compiled lisp files will be placed into a directory 1634 computed from the Lisp version, Operating System and computer archetecture. 1635 See [implementation-specific-directory-name][] for details.") 1636 1637 1638 (defparameter *default-toplevel-directory* 1639 (merge-pathnames 1640 (make-pathname :directory '(:relative ".fasls")) 1641 (truename (user-homedir-pathname))) 1642 "If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.") 1643 1644 (defparameter *include-per-user-information* 1645 nil 1646 "When \\*centralize-lisp-binaries\\* is true this variable controls whether or not to customize the output directory based on the current user. It can be nil, t or a string. If it is nil \(the default\), then no additional information will be added to the output directory. If it is t, then the user's name \(as taken from the return value of #'user-homedir-pathname\) will be included into the centralized path (just before the lisp-implementation directory). Finally, if \\*include-per-user-information\\* is a string, then this string will be included in the output-directory.") 1647 1648 (defparameter *map-all-source-files* 1649 nil 1650 "If true, then all subclasses of source-file will have their output locations mapped by ASDF-Binary-Locations. If nil (the default), then only subclasses of cl-source-file will be mapped.") 1651 1652 (defvar *source-to-target-mappings* 1653 #-sbcl 1654 nil 1655 #+sbcl 1656 (list (list (princ-to-string (sb-ext:posix-getenv "SBCL_HOME")) nil)) 1657 "The \\*source-to-target-mappings\\* variable specifies mappings from source to target. If the target is nil, then it means to not map the source to anything. I.e., to leave it as is. This has the effect of turning off ASDF-Binary-Locations for the given source directory. Examples: 1658 1659 ;; compile everything in .../src and below into .../cmucl 1660 '((\"/nfs/home/compbio/d95-bli/share/common-lisp/src/\" 1661 \"/nfs/home/compbio/d95-bli/lib/common-lisp/cmucl/\")) 1662 1663 ;; leave SBCL innards alone (SBCL specific) 1664 (list (list (princ-to-string (sb-ext:posix-getenv \"SBCL_HOME\")) nil)) 1665 ") 2282 ;;; produce a string to identify current implementation. 2283 ;;; Initially stolen from SLIME's SWANK, hacked since. 1666 2284 1667 2285 (defparameter *implementation-features* 1668 '(:allegro :lispworks :sbcl :c cl :openmcl :cmu :clisp2286 '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp 1669 2287 :corman :cormanlisp :armedbear :gcl :ecl :scl)) 1670 2288 1671 2289 (defparameter *os-features* 1672 '(:windows :mswindows :win32 :mingw32 1673 :solaris :sunos 2290 '((:windows :mswindows :win32 :mingw32) 2291 (:solaris :sunos) 2292 :linux ;; for GCL at least, must appear before :bsd. 1674 2293 :macosx :darwin :apple 1675 2294 :freebsd :netbsd :openbsd :bsd 1676 : linux :unix))2295 :unix)) 1677 2296 1678 2297 (defparameter *architecture-features* 1679 '(:amd64 (:x86-64 :x86_64 :x8664-target) :i686 :i586 :pentium3 1680 :i486 (:i386 :pc386 :iapx386) (:x86 :x8632-target) :pentium4 1681 :hppa64 :hppa :ppc64 :ppc32 :powerpc :ppc :sparc64 :sparc)) 1682 1683 ;; note to gwking: this is in slime, system-check, and system-check-server too 2298 '((:x86-64 :amd64 :x86_64 :x8664-target) 2299 (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4) 2300 :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc)) 2301 1684 2302 (defun lisp-version-string () 1685 #+cmu (substitute #\- #\/ 1686 (substitute #\_ #\Space 1687 (lisp-implementation-version))) 1688 #+scl (lisp-implementation-version) 1689 #+sbcl (lisp-implementation-version) 1690 #+ecl (reduce (lambda (x str) (substitute #\_ str x)) 1691 '(#\Space #\: #\( #\)) 1692 :initial-value (lisp-implementation-version)) 1693 #+gcl (let ((s (lisp-implementation-version))) (subseq s 4)) 1694 #+openmcl (format nil "~d.~d~@[-~d~]" 1695 ccl::*openmcl-major-version* 1696 ccl::*openmcl-minor-version* 1697 #+ppc64-target 64 1698 #-ppc64-target nil) 1699 #+lispworks (format nil "~A~@[~A~]" 1700 (lisp-implementation-version) 1701 (when (member :lispworks-64bit *features*) "-64bit")) 1702 #+allegro (format nil 2303 (let ((s (lisp-implementation-version))) 2304 (declare (ignorable s)) 2305 #+allegro (format nil 1703 2306 "~A~A~A~A" 1704 2307 excl::*common-lisp-version-number* 1705 ; ANSI vs MoDeRn 1706 ;; thanks to Robert Goldman and Charley Cox for 1707 ;; an improvement to my hack 1708 (if (eq excl:*current-case-mode* 1709 :case-sensitive-lower) "M" "A") 1710 ;; Note if not using International ACL 1711 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm 1712 (excl:ics-target-case 1713 (:-ics "8") 1714 (:+ics "")) 2308 ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox 2309 (if (eq excl:*current-case-mode* 2310 :case-sensitive-lower) "M" "A") 2311 ;; Note if not using International ACL 2312 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm 2313 (excl:ics-target-case 2314 (:-ics "8") 2315 (:+ics "")) 1715 2316 (if (member :64bit *features*) "-64bit" "")) 1716 #+clisp (let ((s (lisp-implementation-version))) 1717 (subseq s 0 (position #\space s))) 1718 #+armedbear (lisp-implementation-version) 1719 #+cormanlisp (lisp-implementation-version) 1720 #+digitool (subseq (lisp-implementation-version) 8)) 1721 1722 1723 (defparameter *implementation-specific-directory-name* nil) 1724 1725 (defun implementation-specific-directory-name () 1726 "Return a name that can be used as a directory name that is 1727 unique to a Lisp implementation, Lisp implementation version, 1728 operating system, and hardware architecture." 1729 (and *enable-asdf-binary-locations* 1730 (list 1731 (or *implementation-specific-directory-name* 1732 (setf *implementation-specific-directory-name* 1733 (labels 1734 ((fp (thing) 1735 (etypecase thing 1736 (symbol 1737 (let ((feature (find thing *features*))) 1738 (when feature (return-from fp feature)))) 1739 ;; allows features to be lists of which the first 1740 ;; member is the "main name", the rest being aliases 1741 (cons 1742 (dolist (subf thing) 1743 (let ((feature (find subf *features*))) 1744 (when feature (return-from fp (first thing)))))))) 1745 (first-of (features) 1746 (loop for f in features 1747 when (fp f) return it)) 1748 (maybe-warn (value fstring &rest args) 1749 (cond (value) 1750 (t (apply #'warn fstring args) 1751 "unknown")))) 1752 (let ((lisp (maybe-warn (first-of *implementation-features*) 1753 "No implementation feature found in ~a." 1754 *implementation-features*)) 1755 (os (maybe-warn (first-of *os-features*) 1756 "No os feature found in ~a." *os-features*)) 1757 (arch (maybe-warn (first-of *architecture-features*) 1758 "No architecture feature found in ~a." 1759 *architecture-features*)) 1760 (version (maybe-warn (lisp-version-string) 1761 "Don't know how to get Lisp ~ 2317 #+clisp (subseq s 0 (position #\space s)) 2318 #+clozure (format nil "~d.~d-fasl~d" 2319 ccl::*openmcl-major-version* 2320 ccl::*openmcl-minor-version* 2321 (logand ccl::fasl-version #xFF)) 2322 #+cmu (substitute #\- #\/ s) 2323 #+digitool (subseq s 8) 2324 #+ecl (format nil "~A~@[-~A~]" s 2325 (let ((vcs-id (ext:lisp-implementation-vcs-id))) 2326 (when (>= (length vcs-id) 8) 2327 (subseq vcs-id 0 8)))) 2328 #+gcl (subseq s (1+ (position #\space s))) 2329 #+lispworks (format nil "~A~@[~A~]" s 2330 (when (member :lispworks-64bit *features*) "-64bit")) 2331 ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant 2332 #+(or armedbear cormanlisp mcl sbcl scl) s 2333 #-(or allegro armedbear clisp clozure cmu cormanlisp digitool 2334 ecl gcl lispworks mcl sbcl scl) s)) 2335 2336 (defun first-feature (features) 2337 (labels 2338 ((fp (thing) 2339 (etypecase thing 2340 (symbol 2341 (let ((feature (find thing *features*))) 2342 (when feature (return-from fp feature)))) 2343 ;; allows features to be lists of which the first 2344 ;; member is the "main name", the rest being aliases 2345 (cons 2346 (dolist (subf thing) 2347 (when (find subf *features*) (return-from fp (first thing)))))) 2348 nil)) 2349 (loop :for f :in features 2350 :when (fp f) :return :it))) 2351 2352 (defun implementation-type () 2353 (first-feature *implementation-features*)) 2354 2355 (defun implementation-identifier () 2356 (labels 2357 ((maybe-warn (value fstring &rest args) 2358 (cond (value) 2359 (t (apply #'warn fstring args) 2360 "unknown")))) 2361 (let ((lisp (maybe-warn (implementation-type) 2362 "No implementation feature found in ~a." 2363 *implementation-features*)) 2364 (os (maybe-warn (first-feature *os-features*) 2365 "No os feature found in ~a." *os-features*)) 2366 (arch (maybe-warn (first-feature *architecture-features*) 2367 "No architecture feature found in ~a." 2368 *architecture-features*)) 2369 (version (maybe-warn (lisp-version-string) 2370 "Don't know how to get Lisp ~ 1762 2371 implementation version."))) 1763 (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))))) 1764 1765 (defun pathname-prefix-p (prefix pathname) 1766 (let ((prefix-ns (namestring prefix)) 1767 (pathname-ns (namestring pathname))) 1768 (= (length prefix-ns) 1769 (mismatch prefix-ns pathname-ns)))) 1770 1771 (defgeneric output-files-for-system-and-operation 1772 (system operation component source possible-paths) 1773 (:documentation "Returns the directory where the componets output files should be placed. This may depends on the system, the operation and the component. The ASDF default input and outputs are provided in the source and possible-paths parameters.")) 1774 1775 (defun source-to-target-resolved-mappings () 1776 "Answer `*source-to-target-mappings*` with additional entries made 1777 by resolving sources that are symlinks. 1778 1779 As ASDF sometimes resolves symlinks to compute source paths, we must 1780 follow that. For example, if SBCL is installed under a symlink, and 1781 SBCL_HOME is set through that symlink, the default rule above 1782 preventing SBCL contribs from being mapped elsewhere will not be 1783 applied by the plain `*source-to-target-mappings*`." 1784 (loop for mapping in asdf:*source-to-target-mappings* 1785 for (source target) = mapping 1786 for true-source = (and source (resolve-symlinks source)) 1787 if (equal source true-source) 1788 collect mapping 1789 else append (list mapping (list true-source target)))) 1790 1791 (defmethod output-files-for-system-and-operation 1792 ((system system) operation component source possible-paths) 1793 (declare (ignore operation component)) 1794 (output-files-using-mappings 1795 source possible-paths (source-to-target-resolved-mappings))) 1796 1797 (defmethod output-files-using-mappings (source possible-paths path-mappings) 1798 (mapcar 1799 (lambda (path) 1800 (loop for (from to) in path-mappings 1801 when (pathname-prefix-p from source) 1802 do (return 1803 (if to 1804 (merge-pathnames 1805 (make-pathname :type (pathname-type path)) 1806 (merge-pathnames (enough-namestring source from) 1807 to)) 1808 path)) 1809 1810 finally 1811 (return 1812 ;; Instead of just returning the path when we 1813 ;; don't find a mapping, we stick stuff into 1814 ;; the appropriate binary directory based on 1815 ;; the implementation 1816 (if *centralize-lisp-binaries* 1817 (merge-pathnames 1818 (make-pathname 1819 :type (pathname-type path) 1820 :directory `(:relative 1821 ,@(cond ((eq *include-per-user-information* t) 1822 (cdr (pathname-directory 1823 (user-homedir-pathname)))) 1824 ((not (null *include-per-user-information*)) 1825 (list *include-per-user-information*))) 1826 ,@(implementation-specific-directory-name) 1827 ,@(rest (pathname-directory path))) 1828 :defaults path) 1829 *default-toplevel-directory*) 1830 (make-pathname 1831 :type (pathname-type path) 1832 :directory (append 1833 (pathname-directory path) 1834 (implementation-specific-directory-name)) 1835 :defaults path))))) 1836 possible-paths)) 1837 1838 (defmethod output-files 1839 :around ((operation compile-op) (component source-file)) 1840 (if (or *map-all-source-files* 1841 (typecase component 1842 (cl-source-file t) 1843 (t nil))) 1844 (let ((source (component-pathname component )) 1845 (paths (call-next-method))) 1846 (output-files-for-system-and-operation 1847 (component-system component) operation component source paths)) 1848 (call-next-method))) 2372 (substitute-if 2373 #\_ (lambda (x) (find x " /:\\(){}[]$#`'\"")) 2374 (format nil "~(~@{~a~^-~}~)" lisp version os arch))))) 2375 2376 2377 2378 ;;; --------------------------------------------------------------------------- 2379 ;;; Generic support for configuration files 2380 2381 (defparameter *inter-directory-separator* 2382 #+(or unix cygwin) #\: 2383 #-(or unix cygwin) #\;) 2384 2385 (defun user-homedir () 2386 (truename (user-homedir-pathname))) 2387 2388 (defun try-directory-subpath (x sub &key type) 2389 (let* ((p (and x (ensure-directory-pathname x))) 2390 (tp (and p (ignore-errors (truename p)))) 2391 (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p))) 2392 (ts (and sp (ignore-errors (truename sp))))) 2393 (and ts (values sp ts)))) 2394 (defun user-configuration-directories () 2395 (remove-if 2396 #'null 2397 (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) 2398 `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") 2399 ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") 2400 :for dir :in (split-string dirs :separator ":") 2401 :collect (try dir "common-lisp/")) 2402 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2403 ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") 2404 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData 2405 #+(not cygwin) 2406 ,(try (or (getenv "USERPROFILE") (user-homedir)) 2407 "Application Data/common-lisp/config/")) 2408 ,(try (user-homedir) ".config/common-lisp/"))))) 2409 (defun system-configuration-directories () 2410 (remove-if 2411 #'null 2412 (append 2413 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2414 (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) 2415 `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") 2416 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData 2417 ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) 2418 (list #p"/etc/")))) 2419 (defun in-first-directory (dirs x) 2420 (loop :for dir :in dirs 2421 :thereis (and dir (ignore-errors 2422 (truename (merge-pathnames* x (ensure-directory-pathname dir))))))) 2423 (defun in-user-configuration-directory (x) 2424 (in-first-directory (user-configuration-directories) x)) 2425 (defun in-system-configuration-directory (x) 2426 (in-first-directory (system-configuration-directories) x)) 2427 2428 (defun configuration-inheritance-directive-p (x) 2429 (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) 2430 (or (member x kw) 2431 (and (length=n-p x 1) (member (car x) kw))))) 2432 2433 (defun validate-configuration-form (form tag directive-validator 2434 &optional (description tag)) 2435 (unless (and (consp form) (eq (car form) tag)) 2436 (error "Error: Form doesn't specify ~A ~S~%" description form)) 2437 (loop :with inherit = 0 2438 :for directive :in (cdr form) :do 2439 (if (configuration-inheritance-directive-p directive) 2440 (incf inherit) 2441 (funcall directive-validator directive)) 2442 :finally 2443 (unless (= inherit 1) 2444 (error "One and only one of ~S or ~S is required" 2445 :inherit-configuration :ignore-inherited-configuration))) 2446 form) 2447 2448 (defun validate-configuration-file (file validator description) 2449 (let ((forms (read-file-forms file))) 2450 (unless (length=n-p forms 1) 2451 (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) 2452 (funcall validator (car forms)))) 2453 2454 (defun validate-configuration-directory (directory tag validator) 2455 (let ((files (sort (ignore-errors 2456 (directory (make-pathname :name :wild :type :wild :defaults directory) 2457 #+sbcl :resolve-symlinks #+sbcl nil)) 2458 #'string< :key #'namestring))) 2459 `(,tag 2460 ,@(loop :for file :in files :append 2461 (mapcar validator (read-file-forms file))) 2462 :inherit-configuration))) 2463 2464 2465 ;;; --------------------------------------------------------------------------- 2466 ;;; asdf-output-translations 2467 ;;; 2468 ;;; this code is heavily inspired from 2469 ;;; asdf-binary-translations, common-lisp-controller and cl-launch. 2470 ;;; --------------------------------------------------------------------------- 2471 2472 (defvar *output-translations* () 2473 "Either NIL (for uninitialized), or a list of one element, 2474 said element itself being a sorted list of mappings. 2475 Each mapping is a pair of a source pathname and destination pathname, 2476 and the order is by decreasing length of namestring of the source pathname.") 2477 2478 (defvar *user-cache* 2479 (or 2480 (let ((h (getenv "XDG_CACHE_HOME"))) 2481 (and h `(,h "common-lisp" :implementation))) 2482 #+(and windows lispworks) 2483 (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows??? 2484 (and h `(,h "common-lisp" "cache"))) 2485 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2486 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache 2487 (let ((h (or (getenv "USERPROFILE") (user-homedir)))) 2488 (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp"))) 2489 '(:home ".cache" "common-lisp" :implementation))) 2490 (defvar *system-cache* 2491 (or 2492 #+(and windows lispworks) 2493 (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows??? 2494 (and h `(,h "common-lisp" "cache"))) 2495 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 2496 (let ((h (or (getenv "USERPROFILE") (user-homedir)))) 2497 (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp"))) 2498 #+(or unix cygwin) 2499 '("/var/cache/common-lisp" :uid :implementation))) 2500 2501 (defun output-translations () 2502 (car *output-translations*)) 2503 2504 (defun (setf output-translations) (new-value) 2505 (setf *output-translations* 2506 (list 2507 (stable-sort (copy-list new-value) #'> 2508 :key (lambda (x) 2509 (etypecase (car x) 2510 ((eql t) -1) 2511 (pathname 2512 (length (pathname-directory (car x))))))))) 2513 new-value) 2514 2515 (defun output-translations-initialized-p () 2516 (and *output-translations* t)) 2517 2518 (defun clear-output-translations () 2519 "Undoes any initialization of the output translations. 2520 You might want to call that before you dump an image that would be resumed 2521 with a different configuration, so the configuration would be re-read then." 2522 (setf *output-translations* '()) 2523 (values)) 2524 2525 (defparameter *wild-path* 2526 (make-pathname :directory '(:relative :wild-inferiors) 2527 :name :wild :type :wild :version :wild)) 2528 2529 (defparameter *wild-asd* 2530 (make-pathname :directory '(:relative :wild-inferiors) 2531 :name :wild :type "asd" :version :newest)) 2532 2533 (defun wilden (path) 2534 (merge-pathnames* *wild-path* path)) 2535 2536 (defun resolve-absolute-location-component (x wildenp) 2537 (let* ((r 2538 (etypecase x 2539 (pathname x) 2540 (string (ensure-directory-pathname x)) 2541 (cons 2542 (let ((car (resolve-absolute-location-component (car x) nil))) 2543 (if (null (cdr x)) 2544 car 2545 (let ((cdr (resolve-relative-location-component 2546 car (cdr x) wildenp))) 2547 (merge-pathnames* cdr car))))) 2548 ((eql :root) 2549 ;; special magic! we encode such paths as relative pathnames, 2550 ;; but it means "relative to the root of the source pathname's host and device". 2551 (return-from resolve-absolute-location-component 2552 (make-pathname :directory '(:relative)))) 2553 ((eql :home) (user-homedir)) 2554 ((eql :user-cache) (resolve-location *user-cache* nil)) 2555 ((eql :system-cache) (resolve-location *system-cache* nil)) 2556 ((eql :current-directory) (current-directory)))) 2557 (s (if (and wildenp (not (pathnamep x))) 2558 (wilden r) 2559 r))) 2560 (unless (absolute-pathname-p s) 2561 (error "Not an absolute pathname ~S" s)) 2562 s)) 2563 2564 (defun resolve-relative-location-component (super x &optional wildenp) 2565 (let* ((r (etypecase x 2566 (pathname x) 2567 (string x) 2568 (cons 2569 (let ((car (resolve-relative-location-component super (car x) nil))) 2570 (if (null (cdr x)) 2571 car 2572 (let ((cdr (resolve-relative-location-component 2573 (merge-pathnames* car super) (cdr x) wildenp))) 2574 (merge-pathnames* cdr car))))) 2575 ((eql :current-directory) 2576 (relativize-pathname-directory (current-directory))) 2577 ((eql :implementation) (implementation-identifier)) 2578 ((eql :implementation-type) (string-downcase (implementation-type))) 2579 ((eql :uid) (princ-to-string (get-uid))))) 2580 (d (if (pathnamep x) r (ensure-directory-pathname r))) 2581 (s (if (and wildenp (not (pathnamep x))) 2582 (wilden d) 2583 d))) 2584 (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) 2585 (error "pathname ~S is not relative to ~S" s super)) 2586 (merge-pathnames* s super))) 2587 2588 (defun resolve-location (x &optional wildenp) 2589 (if (atom x) 2590 (resolve-absolute-location-component x wildenp) 2591 (loop :with path = (resolve-absolute-location-component (car x) nil) 2592 :for (component . morep) :on (cdr x) 2593 :do (setf path (resolve-relative-location-component 2594 path component (and wildenp (not morep)))) 2595 :finally (return path)))) 2596 2597 (defun location-designator-p (x) 2598 (flet ((componentp (c) (typep c '(or string pathname keyword)))) 2599 (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x))))) 2600 2601 (defun location-function-p (x) 2602 (and 2603 (consp x) 2604 (length=n-p x 2) 2605 (or (and (equal (first x) :function) 2606 (typep (second x) 'symbol)) 2607 (and (equal (first x) 'lambda) 2608 (cddr x) 2609 (length=n-p (second x) 2))))) 2610 2611 (defun validate-output-translations-directive (directive) 2612 (unless 2613 (or (member directive '(:inherit-configuration 2614 :ignore-inherited-configuration 2615 :enable-user-cache :disable-cache)) 2616 (and (consp directive) 2617 (or (and (length=n-p directive 2) 2618 (or (and (eq (first directive) :include) 2619 (typep (second directive) '(or string pathname null))) 2620 (and (location-designator-p (first directive)) 2621 (or (location-designator-p (second directive)) 2622 (location-function-p (second directive)))))) 2623 (and (length=n-p directive 1) 2624 (location-designator-p (first directive)))))) 2625 (error "Invalid directive ~S~%" directive)) 2626 directive) 2627 2628 (defun validate-output-translations-form (form) 2629 (validate-configuration-form 2630 form 2631 :output-translations 2632 'validate-output-translations-directive 2633 "output translations")) 2634 2635 (defun validate-output-translations-file (file) 2636 (validate-configuration-file 2637 file 'validate-output-translations-form "output translations")) 2638 2639 (defun validate-output-translations-directory (directory) 2640 (validate-configuration-directory 2641 directory :output-translations 'validate-output-translations-directive)) 2642 2643 (defun parse-output-translations-string (string) 2644 (cond 2645 ((or (null string) (equal string "")) 2646 '(:output-translations :inherit-configuration)) 2647 ((not (stringp string)) 2648 (error "environment string isn't: ~S" string)) 2649 ((eql (char string 0) #\") 2650 (parse-output-translations-string (read-from-string string))) 2651 ((eql (char string 0) #\() 2652 (validate-output-translations-form (read-from-string string))) 2653 (t 2654 (loop 2655 :with inherit = nil 2656 :with directives = () 2657 :with start = 0 2658 :with end = (length string) 2659 :with source = nil 2660 :for i = (or (position *inter-directory-separator* string :start start) end) :do 2661 (let ((s (subseq string start i))) 2662 (cond 2663 (source 2664 (push (list source (if (equal "" s) nil s)) directives) 2665 (setf source nil)) 2666 ((equal "" s) 2667 (when inherit 2668 (error "only one inherited configuration allowed: ~S" string)) 2669 (setf inherit t) 2670 (push :inherit-configuration directives)) 2671 (t 2672 (setf source s))) 2673 (setf start (1+ i)) 2674 (when (> start end) 2675 (when source 2676 (error "Uneven number of components in source to destination mapping ~S" string)) 2677 (unless inherit 2678 (push :ignore-inherited-configuration directives)) 2679 (return `(:output-translations ,@(nreverse directives))))))))) 2680 2681 (defparameter *default-output-translations* 2682 '(environment-output-translations 2683 user-output-translations-pathname 2684 user-output-translations-directory-pathname 2685 system-output-translations-pathname 2686 system-output-translations-directory-pathname)) 2687 2688 (defun wrapping-output-translations () 2689 `(:output-translations 2690 ;; Some implementations have precompiled ASDF systems, 2691 ;; so we must disable translations for implementation paths. 2692 #+sbcl (,(getenv "SBCL_HOME") ()) 2693 #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually. 2694 #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system 2695 ;; All-import, here is where we want user stuff to be: 2696 :inherit-configuration 2697 ;; These are for convenience, and can be overridden by the user: 2698 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) 2699 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) 2700 ;; If we want to enable the user cache by default, here would be the place: 2701 :enable-user-cache)) 2702 2703 (defparameter *output-translations-file* #p"asdf-output-translations.conf") 2704 (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/") 2705 2706 (defun user-output-translations-pathname () 2707 (in-user-configuration-directory *output-translations-file* )) 2708 (defun system-output-translations-pathname () 2709 (in-system-configuration-directory *output-translations-file*)) 2710 (defun user-output-translations-directory-pathname () 2711 (in-user-configuration-directory *output-translations-directory*)) 2712 (defun system-output-translations-directory-pathname () 2713 (in-system-configuration-directory *output-translations-directory*)) 2714 (defun environment-output-translations () 2715 (getenv "ASDF_OUTPUT_TRANSLATIONS")) 2716 2717 (defgeneric process-output-translations (spec &key inherit collect)) 2718 (defmethod process-output-translations ((x symbol) &key 2719 (inherit *default-output-translations*) 2720 collect) 2721 (process-output-translations (funcall x) :inherit inherit :collect collect)) 2722 (defmethod process-output-translations ((pathname pathname) &key inherit collect) 2723 (cond 2724 ((directory-pathname-p pathname) 2725 (process-output-translations (validate-output-translations-directory pathname) 2726 :inherit inherit :collect collect)) 2727 ((probe-file pathname) 2728 (process-output-translations (validate-output-translations-file pathname) 2729 :inherit inherit :collect collect)) 2730 (t 2731 (inherit-output-translations inherit :collect collect)))) 2732 (defmethod process-output-translations ((string string) &key inherit collect) 2733 (process-output-translations (parse-output-translations-string string) 2734 :inherit inherit :collect collect)) 2735 (defmethod process-output-translations ((x null) &key inherit collect) 2736 (declare (ignorable x)) 2737 (inherit-output-translations inherit :collect collect)) 2738 (defmethod process-output-translations ((form cons) &key inherit collect) 2739 (dolist (directive (cdr (validate-output-translations-form form))) 2740 (process-output-translations-directive directive :inherit inherit :collect collect))) 2741 2742 (defun inherit-output-translations (inherit &key collect) 2743 (when inherit 2744 (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) 2745 2746 (defun process-output-translations-directive (directive &key inherit collect) 2747 (if (atom directive) 2748 (ecase directive 2749 ((:enable-user-cache) 2750 (process-output-translations-directive '(t :user-cache) :collect collect)) 2751 ((:disable-cache) 2752 (process-output-translations-directive '(t t) :collect collect)) 2753 ((:inherit-configuration) 2754 (inherit-output-translations inherit :collect collect)) 2755 ((:ignore-inherited-configuration) 2756 nil)) 2757 (let ((src (first directive)) 2758 (dst (second directive))) 2759 (if (eq src :include) 2760 (when dst 2761 (process-output-translations (pathname dst) :inherit nil :collect collect)) 2762 (when src 2763 (let ((trusrc (or (eql src t) 2764 (let ((loc (resolve-location src t))) 2765 (if (absolute-pathname-p loc) (truenamize loc) loc))))) 2766 (cond 2767 ((location-function-p dst) 2768 (funcall collect 2769 (list trusrc 2770 (if (symbolp (second dst)) 2771 (fdefinition (second dst)) 2772 (eval (second dst)))))) 2773 ((eq dst t) 2774 (funcall collect (list trusrc t))) 2775 (t 2776 (let* ((trudst (make-pathname 2777 :defaults (if dst (resolve-location dst t) trusrc))) 2778 (wilddst (make-pathname 2779 :name :wild :type :wild :version :wild 2780 :defaults trudst))) 2781 (funcall collect (list wilddst t)) 2782 (funcall collect (list trusrc trudst))))))))))) 2783 2784 (defun compute-output-translations (&optional parameter) 2785 "read the configuration, return it" 2786 (remove-duplicates 2787 (while-collecting (c) 2788 (inherit-output-translations 2789 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) 2790 :test 'equal :from-end t)) 2791 2792 (defun initialize-output-translations (&optional parameter) 2793 "read the configuration, initialize the internal configuration variable, 2794 return the configuration" 2795 (setf (output-translations) (compute-output-translations parameter))) 2796 2797 (defun disable-output-translations () 2798 "Initialize output translations in a way that maps every file to itself, 2799 effectively disabling the output translation facility." 2800 (initialize-output-translations 2801 '(:output-translations :disable-cache :ignore-inherited-configuration))) 2802 2803 ;; checks an initial variable to see whether the state is initialized 2804 ;; or cleared. In the former case, return current configuration; in 2805 ;; the latter, initialize. ASDF will call this function at the start 2806 ;; of (asdf:find-system). 2807 (defun ensure-output-translations () 2808 (if (output-translations-initialized-p) 2809 (output-translations) 2810 (initialize-output-translations))) 2811 2812 (defun apply-output-translations (path) 2813 (etypecase path 2814 (logical-pathname 2815 path) 2816 ((or pathname string) 2817 (ensure-output-translations) 2818 (loop :with p = (truenamize path) 2819 :for (source destination) :in (car *output-translations*) 2820 :for root = (when (or (eq source t) 2821 (and (pathnamep source) 2822 (not (absolute-pathname-p source)))) 2823 (pathname-root p)) 2824 :for absolute-source = (cond 2825 ((eq source t) (wilden root)) 2826 (root (merge-pathnames* source root)) 2827 (t source)) 2828 :when (or (eq source t) (pathname-match-p p absolute-source)) 2829 :return 2830 (cond 2831 ((functionp destination) 2832 (funcall destination p absolute-source)) 2833 ((eq destination t) 2834 p) 2835 ((not (pathnamep destination)) 2836 (error "invalid destination")) 2837 ((not (absolute-pathname-p destination)) 2838 (translate-pathname p absolute-source (merge-pathnames* destination root))) 2839 (root 2840 (translate-pathname (directorize-pathname-host-device p) absolute-source destination)) 2841 (t 2842 (translate-pathname p absolute-source destination))) 2843 :finally (return p))))) 2844 2845 (defun last-char (s) 2846 (and (stringp s) (plusp (length s)) (char s (1- (length s))))) 2847 2848 (defun directorize-pathname-host-device (pathname) 2849 (let* ((root (pathname-root pathname)) 2850 (wild-root (wilden root)) 2851 (absolute-pathname (merge-pathnames* pathname root)) 2852 (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) 2853 (separator (last-char (namestring foo))) 2854 (root-namestring (namestring root)) 2855 (root-string 2856 (substitute-if #\/ 2857 (lambda (x) (or (eql x #\:) 2858 (eql x separator))) 2859 root-namestring))) 2860 (multiple-value-bind (relative path filename) 2861 (component-name-to-pathname-components root-string t) 2862 (declare (ignore relative filename)) 2863 (let ((new-base 2864 (make-pathname :defaults root 2865 :directory `(:absolute ,@path)))) 2866 (translate-pathname absolute-pathname wild-root (wilden new-base)))))) 2867 2868 (defmethod output-files :around (operation component) 2869 "Translate output files, unless asked not to" 2870 (declare (ignorable operation component)) 2871 (values 2872 (multiple-value-bind (files fixedp) (call-next-method) 2873 (if fixedp 2874 files 2875 (mapcar #'apply-output-translations files))) 2876 t)) 2877 2878 (defun compile-file-pathname* (input-file &rest keys) 2879 (apply-output-translations 2880 (apply #'compile-file-pathname 2881 (truenamize (lispize-pathname input-file)) 2882 keys))) 2883 2884 #+abcl 2885 (defun translate-jar-pathname (source wildcard) 2886 (declare (ignore wildcard)) 2887 (let* ((p (pathname (first (pathname-device source)))) 2888 (root (format nil "/___jar___file___root___/~@[~A/~]" 2889 (and (find :windows *features*) 2890 (pathname-device p))))) 2891 (apply-output-translations 2892 (merge-pathnames* 2893 (relativize-pathname-directory source) 2894 (merge-pathnames* 2895 (relativize-pathname-directory (ensure-directory-pathname p)) 2896 root))))) 2897 2898 ;;;; ----------------------------------------------------------------- 2899 ;;;; Compatibility mode for ASDF-Binary-Locations 2900 2901 (defun enable-asdf-binary-locations-compatibility 2902 (&key 2903 (centralize-lisp-binaries nil) 2904 (default-toplevel-directory 2905 ;; Use ".cache/common-lisp" instead ??? 2906 (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) 2907 (user-homedir))) 2908 (include-per-user-information nil) 2909 (map-all-source-files nil) 2910 (source-to-target-mappings nil)) 2911 (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) 2912 (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) 2913 (mapped-files (make-pathname 2914 :name :wild :version :wild 2915 :type (if map-all-source-files :wild fasl-type))) 2916 (destination-directory 2917 (if centralize-lisp-binaries 2918 `(,default-toplevel-directory 2919 ,@(when include-per-user-information 2920 (cdr (pathname-directory (user-homedir)))) 2921 :implementation ,wild-inferiors) 2922 `(:root ,wild-inferiors :implementation)))) 2923 (initialize-output-translations 2924 `(:output-translations 2925 ,@source-to-target-mappings 2926 ((:root ,wild-inferiors ,mapped-files) 2927 (,@destination-directory ,mapped-files)) 2928 (t t) 2929 :ignore-inherited-configuration)))) 1849 2930 1850 2931 ;;;; ----------------------------------------------------------------- … … 1853 2934 ;;;; Jesse Hager: The Windows Shortcut File Format. 1854 2935 ;;;; http://www.wotsit.org/list.asp?fc=13 1855 ;;;; -----------------------------------------------------------------1856 2936 1857 2937 (defparameter *link-initial-dword* 76) … … 1860 2940 (defun read-null-terminated-string (s) 1861 2941 (with-output-to-string (out) 1862 (loop 1863 for code = (read-byte s) 1864 until (zerop code) 1865 do (write-char (code-char code) out)))) 2942 (loop :for code = (read-byte s) 2943 :until (zerop code) 2944 :do (write-char (code-char code) out)))) 1866 2945 1867 2946 (defun read-little-endian (s &optional (bytes 4)) 1868 (let ((result 0)) 1869 (loop 1870 for i from 0 below bytes 1871 do 1872 (setf result (logior result (ash (read-byte s) (* 8 i))))) 1873 result)) 2947 (loop 2948 :for i :from 0 :below bytes 2949 :sum (ash (read-byte s) (* 8 i)))) 2950 2951 (defun parse-file-location-info (s) 2952 (let ((start (file-position s)) 2953 (total-length (read-little-endian s)) 2954 (end-of-header (read-little-endian s)) 2955 (fli-flags (read-little-endian s)) 2956 (local-volume-offset (read-little-endian s)) 2957 (local-offset (read-little-endian s)) 2958 (network-volume-offset (read-little-endian s)) 2959 (remaining-offset (read-little-endian s))) 2960 (declare (ignore total-length end-of-header local-volume-offset)) 2961 (unless (zerop fli-flags) 2962 (cond 2963 ((logbitp 0 fli-flags) 2964 (file-position s (+ start local-offset))) 2965 ((logbitp 1 fli-flags) 2966 (file-position s (+ start 2967 network-volume-offset 2968 #x14)))) 2969 (concatenate 'string 2970 (read-null-terminated-string s) 2971 (progn 2972 (file-position s (+ start remaining-offset)) 2973 (read-null-terminated-string s)))))) 1874 2974 1875 2975 (defun parse-windows-shortcut (pathname) 1876 2976 (with-open-file (s pathname :element-type '(unsigned-byte 8)) 1877 2977 (handler-case 1878 1879 1880 1881 1882 1883 (file-position s 76);skip rest of header1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 2978 (when (and (= (read-little-endian s) *link-initial-dword*) 2979 (let ((header (make-array (length *link-guid*)))) 2980 (read-sequence header s) 2981 (equalp header *link-guid*))) 2982 (let ((flags (read-little-endian s))) 2983 (file-position s 76) ;skip rest of header 2984 (when (logbitp 0 flags) 2985 ;; skip shell item id list 2986 (let ((length (read-little-endian s 2))) 2987 (file-position s (+ length (file-position s))))) 2988 (cond 2989 ((logbitp 1 flags) 2990 (parse-file-location-info s)) 2991 (t 2992 (when (logbitp 2 flags) 2993 ;; skip description string 2994 (let ((length (read-little-endian s 2))) 2995 (file-position s (+ length (file-position s))))) 2996 (when (logbitp 3 flags) 2997 ;; finally, our pathname 2998 (let* ((length (read-little-endian s 2)) 2999 (buffer (make-array length))) 3000 (read-sequence buffer s) 3001 (map 'string #'code-char buffer))))))) 1902 3002 (end-of-file () 1903 nil)))) 1904 1905 (defun parse-file-location-info (s) 1906 (let ((start (file-position s)) 1907 (total-length (read-little-endian s)) 1908 (end-of-header (read-little-endian s)) 1909 (fli-flags (read-little-endian s)) 1910 (local-volume-offset (read-little-endian s)) 1911 (local-offset (read-little-endian s)) 1912 (network-volume-offset (read-little-endian s)) 1913 (remaining-offset (read-little-endian s))) 1914 (declare (ignore total-length end-of-header local-volume-offset)) 1915 (unless (zerop fli-flags) 1916 (cond 1917 ((logbitp 0 fli-flags) 1918 (file-position s (+ start local-offset))) 1919 ((logbitp 1 fli-flags) 1920 (file-position s (+ start 1921 network-volume-offset 1922 #x14)))) 1923 (concatenate 'string 1924 (read-null-terminated-string s) 1925 (progn 1926 (file-position s (+ start remaining-offset)) 1927 (read-null-terminated-string s)))))) 1928 1929 1930 (pushnew :asdf *features*) 1931 1932 #+sbcl 1933 (eval-when (:compile-toplevel :load-toplevel :execute) 1934 (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") 1935 (pushnew :sbcl-hooks-require *features*))) 1936 1937 #+(and sbcl sbcl-hooks-require) 3003 nil)))) 3004 3005 ;;;; ----------------------------------------------------------------- 3006 ;;;; Source Registry Configuration, by Francois-Rene Rideau 3007 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 3008 3009 ;; Using ack 1.2 exclusions 3010 (defvar *default-exclusions* 3011 '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" 3012 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" 3013 "_sgbak" "autom4te.cache" "cover_db" "_build")) 3014 3015 (defvar *source-registry* () 3016 "Either NIL (for uninitialized), or a list of one element, 3017 said element itself being a list of directory pathnames where to look for .asd files") 3018 3019 (defun source-registry () 3020 (car *source-registry*)) 3021 3022 (defun (setf source-registry) (new-value) 3023 (setf *source-registry* (list new-value)) 3024 new-value) 3025 3026 (defun source-registry-initialized-p () 3027 (and *source-registry* t)) 3028 3029 (defun clear-source-registry () 3030 "Undoes any initialization of the source registry. 3031 You might want to call that before you dump an image that would be resumed 3032 with a different configuration, so the configuration would be re-read then." 3033 (setf *source-registry* '()) 3034 (values)) 3035 3036 (defun probe-asd (name defaults) 3037 (block nil 3038 (when (directory-pathname-p defaults) 3039 (let ((file 3040 (make-pathname 3041 :defaults defaults :version :newest :case :local 3042 :name name 3043 :type "asd"))) 3044 (when (probe-file file) 3045 (return file))) 3046 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) 3047 (let ((shortcut 3048 (make-pathname 3049 :defaults defaults :version :newest :case :local 3050 :name (concatenate 'string name ".asd") 3051 :type "lnk"))) 3052 (when (probe-file shortcut) 3053 (let ((target (parse-windows-shortcut shortcut))) 3054 (when target 3055 (return (pathname target))))))))) 3056 3057 (defun sysdef-source-registry-search (system) 3058 (ensure-source-registry) 3059 (loop :with name = (coerce-name system) 3060 :for defaults :in (source-registry) 3061 :for file = (probe-asd name defaults) 3062 :when file :return file)) 3063 3064 (defun validate-source-registry-directive (directive) 3065 (unless 3066 (or (member directive '(:default-registry (:default-registry)) :test 'equal) 3067 (destructuring-bind (kw &rest rest) directive 3068 (case kw 3069 ((:include :directory :tree) 3070 (and (length=n-p rest 1) 3071 (typep (car rest) '(or pathname string null)))) 3072 ((:exclude) 3073 (every #'stringp rest)) 3074 (null rest)))) 3075 (error "Invalid directive ~S~%" directive)) 3076 directive) 3077 3078 (defun validate-source-registry-form (form) 3079 (validate-configuration-form 3080 form :source-registry 'validate-source-registry-directive "a source registry")) 3081 3082 (defun validate-source-registry-file (file) 3083 (validate-configuration-file 3084 file 'validate-source-registry-form "a source registry")) 3085 3086 (defun validate-source-registry-directory (directory) 3087 (validate-configuration-directory 3088 directory :source-registry 'validate-source-registry-directive)) 3089 3090 (defun parse-source-registry-string (string) 3091 (cond 3092 ((or (null string) (equal string "")) 3093 '(:source-registry :inherit-configuration)) 3094 ((not (stringp string)) 3095 (error "environment string isn't: ~S" string)) 3096 ((find (char string 0) "\"(") 3097 (validate-source-registry-form (read-from-string string))) 3098 (t 3099 (loop 3100 :with inherit = nil 3101 :with directives = () 3102 :with start = 0 3103 :with end = (length string) 3104 :for pos = (position *inter-directory-separator* string :start start) :do 3105 (let ((s (subseq string start (or pos end)))) 3106 (cond 3107 ((equal "" s) ; empty element: inherit 3108 (when inherit 3109 (error "only one inherited configuration allowed: ~S" string)) 3110 (setf inherit t) 3111 (push ':inherit-configuration directives)) 3112 ((ends-with s "//") 3113 (push `(:tree ,(subseq s 0 (1- (length s)))) directives)) 3114 (t 3115 (push `(:directory ,s) directives))) 3116 (cond 3117 (pos 3118 (setf start (1+ pos))) 3119 (t 3120 (unless inherit 3121 (push '(:ignore-inherited-configuration) directives)) 3122 (return `(:source-registry ,@(nreverse directives)))))))))) 3123 3124 (defun register-asd-directory (directory &key recurse exclude collect) 3125 (if (not recurse) 3126 (funcall collect directory) 3127 (let* ((files 3128 (handler-case 3129 (directory (merge-pathnames* *wild-asd* directory) 3130 #+sbcl #+sbcl :resolve-symlinks nil 3131 #+clisp #+clisp :circle t) 3132 (error (c) 3133 (warn "Error while scanning system definitions under directory ~S:~%~A" 3134 directory c) 3135 nil))) 3136 (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) 3137 :test #'equal :from-end t))) 3138 (loop 3139 :for dir :in dirs 3140 :unless (loop :for x :in exclude 3141 :thereis (find x (pathname-directory dir) :test #'equal)) 3142 :do (funcall collect dir))))) 3143 3144 (defparameter *default-source-registries* 3145 '(environment-source-registry 3146 user-source-registry 3147 user-source-registry-directory 3148 system-source-registry 3149 system-source-registry-directory 3150 default-source-registry)) 3151 3152 (defparameter *source-registry-file* #p"source-registry.conf") 3153 (defparameter *source-registry-directory* #p"source-registry.conf.d/") 3154 3155 (defun wrapping-source-registry () 3156 `(:source-registry 3157 #+sbcl (:tree ,(getenv "SBCL_HOME")) 3158 :inherit-configuration)) 3159 (defun default-source-registry () 3160 (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) 3161 `(:source-registry 3162 #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) 3163 (:directory ,(truenamize (directory-namestring *default-pathname-defaults*))) 3164 ,@(let* 3165 #+(or unix cygwin) 3166 ((datahome 3167 (or (getenv "XDG_DATA_HOME") 3168 (try (user-homedir) ".local/share/"))) 3169 (datadirs 3170 (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) 3171 (dirs (cons datahome (split-string datadirs :separator ":")))) 3172 #+(and (or win32 windows mswindows mingw32) (not cygwin)) 3173 ((datahome 3174 #+lispworks (sys:get-folder-path :common-appdata) 3175 #-lispworks (try (or (getenv "USERPROFILE") (user-homedir)) 3176 "Application Data")) 3177 (datadir 3178 #+lispworks (sys:get-folder-path :local-appdata) 3179 #-lispworks (try (getenv "ALLUSERSPROFILE") 3180 "Application Data")) 3181 (dirs (list datahome datadir))) 3182 #-(or unix win32 windows mswindows mingw32 cygwin) 3183 ((dirs ())) 3184 (loop :for dir :in dirs 3185 :collect `(:directory ,(try dir "common-lisp/systems/")) 3186 :collect `(:tree ,(try dir "common-lisp/source/")))) 3187 :inherit-configuration))) 3188 (defun user-source-registry () 3189 (in-user-configuration-directory *source-registry-file*)) 3190 (defun system-source-registry () 3191 (in-system-configuration-directory *source-registry-file*)) 3192 (defun user-source-registry-directory () 3193 (in-user-configuration-directory *source-registry-directory*)) 3194 (defun system-source-registry-directory () 3195 (in-system-configuration-directory *source-registry-directory*)) 3196 (defun environment-source-registry () 3197 (getenv "CL_SOURCE_REGISTRY")) 3198 3199 (defgeneric process-source-registry (spec &key inherit register)) 3200 (defmethod process-source-registry ((x symbol) &key inherit register) 3201 (process-source-registry (funcall x) :inherit inherit :register register)) 3202 (defmethod process-source-registry ((pathname pathname) &key inherit register) 3203 (cond 3204 ((directory-pathname-p pathname) 3205 (process-source-registry (validate-source-registry-directory pathname) 3206 :inherit inherit :register register)) 3207 ((probe-file pathname) 3208 (process-source-registry (validate-source-registry-file pathname) 3209 :inherit inherit :register register)) 3210 (t 3211 (inherit-source-registry inherit :register register)))) 3212 (defmethod process-source-registry ((string string) &key inherit register) 3213 (process-source-registry (parse-source-registry-string string) 3214 :inherit inherit :register register)) 3215 (defmethod process-source-registry ((x null) &key inherit register) 3216 (declare (ignorable x)) 3217 (inherit-source-registry inherit :register register)) 3218 (defmethod process-source-registry ((form cons) &key inherit register) 3219 (let ((*default-exclusions* *default-exclusions*)) 3220 (dolist (directive (cdr (validate-source-registry-form form))) 3221 (process-source-registry-directive directive :inherit inherit :register register)))) 3222 3223 (defun inherit-source-registry (inherit &key register) 3224 (when inherit 3225 (process-source-registry (first inherit) :register register :inherit (rest inherit)))) 3226 3227 (defun process-source-registry-directive (directive &key inherit register) 3228 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) 3229 (ecase kw 3230 ((:include) 3231 (destructuring-bind (pathname) rest 3232 (process-source-registry (pathname pathname) :inherit nil :register register))) 3233 ((:directory) 3234 (destructuring-bind (pathname) rest 3235 (when pathname 3236 (funcall register (ensure-directory-pathname pathname))))) 3237 ((:tree) 3238 (destructuring-bind (pathname) rest 3239 (when pathname 3240 (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*)))) 3241 ((:exclude) 3242 (setf *default-exclusions* rest)) 3243 ((:default-registry) 3244 (inherit-source-registry '(default-source-registry) :register register)) 3245 ((:inherit-configuration) 3246 (inherit-source-registry inherit :register register)) 3247 ((:ignore-inherited-configuration) 3248 nil)))) 3249 3250 (defun flatten-source-registry (&optional parameter) 3251 (remove-duplicates 3252 (while-collecting (collect) 3253 (inherit-source-registry 3254 `(wrapping-source-registry 3255 ,parameter 3256 ,@*default-source-registries*) 3257 :register (lambda (directory &key recurse exclude) 3258 (collect (list directory :recurse recurse :exclude exclude))))) 3259 :test 'equal :from-end t)) 3260 3261 ;; Will read the configuration and initialize all internal variables, 3262 ;; and return the new configuration. 3263 (defun compute-source-registry (&optional parameter) 3264 (while-collecting (collect) 3265 (dolist (entry (flatten-source-registry parameter)) 3266 (destructuring-bind (directory &key recurse exclude) entry 3267 (register-asd-directory 3268 directory 3269 :recurse recurse :exclude exclude :collect #'collect))))) 3270 3271 (defun initialize-source-registry (&optional parameter) 3272 (setf (source-registry) (compute-source-registry parameter))) 3273 3274 ;; checks an initial variable to see whether the state is initialized 3275 ;; or cleared. In the former case, return current configuration; in 3276 ;; the latter, initialize. ASDF will call this function at the start 3277 ;; of (asdf:find-system). 3278 (defun ensure-source-registry () 3279 (if (source-registry-initialized-p) 3280 (source-registry) 3281 (initialize-source-registry))) 3282 3283 ;;;; ----------------------------------------------------------------- 3284 ;;;; Hook into REQUIRE for SBCL, ClozureCL and ABCL 3285 ;;;; 3286 #+(or sbcl clozure abcl) 1938 3287 (progn 1939 3288 (defun module-provide-asdf (name) 1940 (handler-bind ((style-warning #'muffle-warning)) 3289 (handler-bind 3290 ((style-warning #'muffle-warning) 3291 (missing-component (constantly nil)) 3292 (error (lambda (e) 3293 (format *error-output* "ASDF could not load ~A because ~A.~%" 3294 name e)))) 1941 3295 (let* ((*verbose-out* (make-broadcast-stream)) 1942 (system ( asdf:find-system name nil)))3296 (system (find-system name nil))) 1943 3297 (when system 1944 ( asdf:operate 'asdf:load-opname)3298 (load-system name) 1945 3299 t)))) 1946 1947 (defun contrib-sysdef-search (system) 1948 (let ((home (sb-ext:posix-getenv "SBCL_HOME"))) 1949 (when (and home (not (string= home ""))) 1950 (let* ((name (coerce-name system)) 1951 (home (truename home)) 1952 (contrib (merge-pathnames 1953 (make-pathname :directory `(:relative ,name) 1954 :name name 1955 :type "asd" 1956 :case :local 1957 :version :newest) 1958 home))) 1959 (probe-file contrib))))) 1960 1961 (pushnew 1962 '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) 1963 (when (and home (not (string= home ""))) 1964 (merge-pathnames "site-systems/" (truename home)))) 1965 *central-registry*) 1966 1967 (pushnew 1968 '(merge-pathnames ".sbcl/systems/" 1969 (user-homedir-pathname)) 1970 *central-registry*) 1971 1972 (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) 1973 (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) 1974 1975 (if *asdf-revision* 1976 (asdf-message ";; ASDF, revision ~a" *asdf-revision*) 1977 (asdf-message ";; ASDF, revision unknown; possibly a development version")) 1978 1979 (provide 'asdf) 1980 1981 1982 #+(or) 1983 ;;?? ignore -- so how will ABL get "installed" 1984 ;; should be unnecessary with newer versions of ASDF 1985 ;; load customizations 1986 (eval-when (:load-toplevel :execute) 1987 (let* ((*package* (find-package :common-lisp))) 1988 (load 1989 (merge-pathnames 1990 (make-pathname :name "asdf-binary-locations" 1991 :type "lisp" 1992 :directory '(:relative ".asdf")) 1993 (truename (user-homedir-pathname))) 1994 :if-does-not-exist nil))) 3300 (pushnew 'module-provide-asdf 3301 #+sbcl sb-ext:*module-provider-functions* 3302 #+clozure ccl::*module-provider-functions* 3303 #+abcl sys::*module-provider-functions*)) 3304 3305 ;;;; ------------------------------------------------------------------------- 3306 ;;;; Cleanups after hot-upgrade. 3307 ;;;; Things to do in case we're upgrading from a previous version of ASDF. 3308 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 3309 ;;;; 3310 ;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1 3311 (eval-when (:compile-toplevel :load-toplevel :execute) 3312 #+ecl ;; Support upgrade from before ECL went to 1.369 3313 (when (fboundp 'compile-op-system-p) 3314 (defmethod compile-op-system-p ((op compile-op)) 3315 (getf :system-p (compile-op-flags op))) 3316 (defmethod initialize-instance :after ((op compile-op) 3317 &rest initargs 3318 &key system-p &allow-other-keys) 3319 (declare (ignorable initargs)) 3320 (when system-p (appendf (compile-op-flags op) (list :system-p system-p)))))) 3321 3322 ;;;; ----------------------------------------------------------------- 3323 ;;;; Done! 3324 (when *load-verbose* 3325 (asdf-message ";; ASDF, version ~a" (asdf-version))) 3326 3327 #+allegro 3328 (eval-when (:compile-toplevel :execute) 3329 (when (boundp 'excl:*warn-on-nested-reader-conditionals*) 3330 (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) 3331 3332 (pushnew :asdf *features*) 3333 ;; this is a release candidate for ASDF 2.0 3334 (pushnew :asdf2 *features*) 3335 3336 (provide :asdf) 3337 3338 ;;; Local Variables: 3339 ;;; mode: lisp 3340 ;;; End:
Note: See TracChangeset
for help on using the changeset viewer.