source: release/1.4/source/tools/asdf.lisp @ 13031

Last change on this file since 13031 was 13031, checked in by rme, 11 years ago

Trunk changes r12910 through r13030 (need to update interfaces separately).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 74.9 KB
Line 
1;;; This is asdf: Another System Definition Facility.
2;;; hash - $Format:%H$
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/>
12;;;
13;;; If you obtained this copy from anywhere else, and you experience
14;;; trouble using it, or find bugs, you may want to check at the
15;;; location above for a more recent version (and for documentation
16;;; and test files, if your copy came without them) before reporting
17;;; bugs.  There are usually two "supported" revisions - the git HEAD
18;;; is the latest development version, whereas the revision tagged
19;;; RELEASE may be slightly older but is considered `stable'
20
21;;; -- LICENSE START
22;;; (This is the MIT / X Consortium license as taken from
23;;;  http://www.opensource.org/licenses/mit-license.html on or about
24;;;  Monday; July 13, 2009)
25;;;
26;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
27;;;
28;;; Permission is hereby granted, free of charge, to any person obtaining
29;;; a copy of this software and associated documentation files (the
30;;; "Software"), to deal in the Software without restriction, including
31;;; without limitation the rights to use, copy, modify, merge, publish,
32;;; distribute, sublicense, and/or sell copies of the Software, and to
33;;; permit persons to whom the Software is furnished to do so, subject to
34;;; the following conditions:
35;;;
36;;; The above copyright notice and this permission notice shall be
37;;; included in all copies or substantial portions of the Software.
38;;;
39;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
40;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
41;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
42;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
43;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
44;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
45;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
46;;;
47;;; -- LICENSE END
48
49;;; the problem with writing a defsystem replacement is bootstrapping:
50;;; we can't use defsystem to compile it.  Hence, all in one file
51
52#+xcvb (module ())
53
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 
152
153(defvar *resolve-symlinks* t
154  "Determine whether or not ASDF resolves symlinks when defining systems.
155
156Defaults to `t`.")
157
158(defvar *compile-file-warnings-behaviour* :warn)
159
160(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
161
162(defvar *verbose-out* nil)
163
164(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,
197but defines a new method-qualifier, `asdf:around`.  `asdf:around`
198methods will be run *around* any `:around` methods, so that the core
199protocol may employ around methods and those around methods will not
200be 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))
212
213(defgeneric system-source-file (system)
214  (:documentation "Return the source file in which system is defined."))
215
216(defgeneric component-system (component)
217  (:documentation "Find the top-level system containing COMPONENT"))
218
219(defgeneric component-pathname (component)
220  (:documentation "Extracts the pathname applicable for a particular component."))
221
222(defgeneric component-relative-pathname (component)
223  (:documentation "Extracts the relative pathname applicable for a particular component."))
224
225(defgeneric component-property (component property))
226
227(defgeneric (setf component-property) (new-value component property))
228
229(defgeneric version-satisfies (component version))
230
231(defgeneric find-component (module name &optional version)
232  (:documentation "Finds the component with name NAME present in the
233MODULE module; if MODULE is nil, then the component is assumed to be a
234system."))
235
236(defgeneric source-file-type (component system))
237
238(defgeneric operation-ancestor (operation)
239  (:documentation
240   "Recursively chase the operation's parent pointer until we get to
241the head of the tree"))
242
243(defgeneric component-visited-p (operation component))
244
245(defgeneric visit-component (operation component data))
246
247(defgeneric (setf visiting-component) (new-value operation component))
248
249(defgeneric component-visiting-p (operation component))
250
251(defgeneric component-depends-on (operation component)
252  (:documentation
253   "Returns a list of dependencies needed by the component to perform
254    the operation.  A dependency has one of the following forms:
255
256      (<operation> <component>*), where <operation> is a class
257        designator and each <component> is a component
258        designator, which means that the component depends on
259        <operation> having been performed on each <component>; or
260
261      (FEATURE <feature>), which means that the component depends
262        on <feature>'s presence in *FEATURES*.
263
264    Methods specialized on subclasses of existing component types
265    should usually append the results of CALL-NEXT-METHOD to the
266    list."))
267
268(defgeneric component-self-dependencies (operation component))
269
270(defgeneric traverse (operation component)
271  (:documentation 
272"Generate and return a plan for performing `operation` on `component`.
273
274The plan returned is a list of dotted-pairs. Each pair is the `cons`
275of ASDF operation object and a `component` object. The pairs will be
276processed in order by `operate`."))
277
278(defgeneric output-files-using-mappings (source possible-paths path-mappings)
279  (:documentation 
280"Use the variable \\*source-to-target-mappings\\* to find
281an output path for the source. The algorithm transforms each
282entry in possible-paths as follows: If there is a mapping
283whose source starts with the path of possible-path, then
284replace possible-path with a pathname that starts with the
285target of the mapping and continues with the rest of
286possible-path. If no such mapping is found, then use the
287default mapping.
288
289If \\*centralize-lisp-binaries\\* is false, then the default
290mapping is to place the output in a subdirectory of the
291source. The subdirectory is named using the Lisp
292implementation \(see
293implementation-specific-directory-name\). If
294\\*centralize-lisp-binaries\\* is true, then the default
295mapping is to place the output in subdirectories of
296\\*default-toplevel-directory\\* where the subdirectory
297structure will mirror that of the source."))
298
299
300;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
301;; utility stuff
302
303(defmacro aif (test then &optional else)
304  `(let ((it ,test)) (if it ,then ,else)))
305
306(defun pathname-sans-name+type (pathname)
307  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
308and NIL NAME and TYPE components"
309  (make-pathname :name nil :type nil :defaults pathname))
310
311(define-modify-macro appendf (&rest args)
312  append "Append onto list")
313
314(defun asdf-message (format-string &rest format-args)
315  (declare (dynamic-extent format-args))
316  (apply #'format *verbose-out* format-string format-args))
317
318(defun split-path-string (s &optional force-directory)
319  (check-type s string)
320  (let* ((components (split s nil "/"))
321         (last-comp (car (last components))))
322    (multiple-value-bind (relative components)
323        (if (equal (first components) "")
324          (values :absolute (cdr components))
325          (values :relative components))
326      (cond
327        ((equal last-comp "")
328         (values relative (butlast components) nil))
329        (force-directory
330         (values relative components nil))
331        (t
332         (values relative (butlast components) last-comp))))))
333
334;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335;; classes, condiitons
336
337(define-condition system-definition-error (error) ()
338  ;; [this use of :report should be redundant, but unfortunately it's not.
339  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
340  ;; over print-object; this is always conditions::%print-condition for
341  ;; condition objects, which in turn does inheritance of :report options at
342  ;; run-time.  fortunately, inheritance means we only need this kludge here in
343  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
344  #+cmu (:report print-object))
345
346(define-condition formatted-system-definition-error (system-definition-error)
347  ((format-control :initarg :format-control :reader format-control)
348   (format-arguments :initarg :format-arguments :reader format-arguments))
349  (:report (lambda (c s)
350             (apply #'format s (format-control c) (format-arguments c)))))
351
352(define-condition circular-dependency (system-definition-error)
353  ((components :initarg :components :reader circular-dependency-components)))
354
355(define-condition duplicate-names (system-definition-error)
356  ((name :initarg :name :reader duplicate-names-name)))
357
358(define-condition missing-component (system-definition-error)
359  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
360   (parent :initform nil :reader missing-parent :initarg :parent)))
361
362(define-condition missing-component-of-version (missing-component)
363  ((version :initform nil :reader missing-version :initarg :version)))
364
365(define-condition missing-dependency (missing-component)
366  ((required-by :initarg :required-by :reader missing-required-by)))
367
368(define-condition missing-dependency-of-version (missing-dependency
369                                                 missing-component-of-version)
370  ())
371
372(define-condition operation-error (error)
373  ((component :reader error-component :initarg :component)
374   (operation :reader error-operation :initarg :operation))
375  (:report (lambda (c s)
376             (format s "~@<erred while invoking ~A on ~A~@:>"
377                     (error-operation c) (error-component c)))))
378(define-condition compile-error (operation-error) ())
379(define-condition compile-failed (compile-error) ())
380(define-condition compile-warned (compile-error) ())
381
382(defclass component ()
383  ((name :accessor component-name :initarg :name :documentation
384         "Component name: designator for a string composed of portable pathname characters")
385   (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)
389   ;; methods defined using the "inline" style inside a defsystem form:
390   ;; need to store them somewhere so we can delete them when the system
391   ;; is re-evaluated
392   (inline-methods :accessor component-inline-methods :initform nil)
393   (parent :initarg :parent :initform nil :reader component-parent)
394   ;; no direct accessor for pathname, we do this as a method to allow
395   ;; it to default in funky ways if not supplied
396   (relative-pathname :initarg :pathname)
397   (operation-times :initform (make-hash-table )
398                    :accessor component-operation-times)
399   ;; XXX we should provide some atomic interface for updating the
400   ;; component properties
401   (properties :accessor component-properties :initarg :properties
402               :initform nil)))
403
404;;;; methods: conditions
405
406(defmethod print-object ((c missing-dependency) s)
407  (format s "~@<~A, required by ~A~@:>"
408          (call-next-method c nil) (missing-required-by c)))
409
410(defun sysdef-error (format &rest arguments)
411  (error 'formatted-system-definition-error :format-control 
412         format :format-arguments arguments))
413
414;;;; methods: components
415
416(defmethod print-object ((c missing-component) s)
417   (format s "~@<component ~S not found~
418             ~@[ in ~A~]~@:>"
419          (missing-requires c)
420          (when (missing-parent c)
421            (component-name (missing-parent c)))))
422
423(defmethod print-object ((c missing-component-of-version) s)
424  (format s "~@<component ~S does not match version ~A~
425              ~@[ in ~A~]~@:>"
426           (missing-requires c)
427           (missing-version c)
428           (when (missing-parent c)
429             (component-name (missing-parent c)))))
430
431(defmethod component-system ((component component))
432  (aif (component-parent component)
433       (component-system it)
434       component))
435
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))))
440
441(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)))
450
451(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))))))
463
464(defmethod component-pathname ((component component))
465  (let ((*default-pathname-defaults* (component-parent-pathname component)))
466    (merge-pathnames (component-relative-pathname component))))
467
468(defmethod component-property ((c component) property)
469  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
470
471(defmethod (setf component-property) (new-value (c component) property)
472  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
473    (if a
474        (setf (cdr a) new-value)
475        (setf (slot-value c 'properties)
476              (acons property new-value (slot-value c 'properties))))))
477
478(defclass system (module)
479  ((description :accessor system-description :initarg :description)
480   (long-description
481    :accessor system-long-description :initarg :long-description)
482   (author :accessor system-author :initarg :author)
483   (maintainer :accessor system-maintainer :initarg :maintainer)
484   (licence :accessor system-licence :initarg :licence
485            :accessor system-license :initarg :license)
486   (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)))))))
504
505(defmethod version-satisfies ((c component) version)
506  (unless (and version (slot-boundp c 'version))
507    (return-from version-satisfies t))
508  (let ((x (mapcar #'parse-integer
509                   (split (component-version c) nil '(#\.))))
510        (y (mapcar #'parse-integer
511                   (split version nil '(#\.)))))
512    (labels ((bigger (x y)
513               (cond ((not y) t)
514                     ((not x) nil)
515                     ((> (car x) (car y)) t)
516                     ((= (car x) (car y))
517                      (bigger (cdr x) (cdr y))))))
518      (and (= (car x) (car y))
519           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
520
521;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
522;;; finding systems
523
524(defun make-defined-systems-table ()
525  (make-hash-table :test 'equal))
526
527(defvar *defined-systems* (make-defined-systems-table))
528
529(defun coerce-name (name)
530  (typecase name
531    (component (component-name name))
532    (symbol (string-downcase (symbol-name name)))
533    (string name)
534    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
535
536(defun system-registered-p (name)
537  (gethash (coerce-name name) *defined-systems*))
538
539(defun map-systems (fn)
540  "Apply `fn` to each defined system.
541
542`fn` should be a function of one argument. It will be
543called with an object of type asdf:system."
544  (maphash (lambda (_ datum)
545             (declare (ignore _))
546             (destructuring-bind (_ . def) datum
547               (declare (ignore _))
548               (funcall fn def)))
549           *defined-systems*))
550
551;;; for the sake of keeping things reasonably neat, we adopt a
552;;; convention that functions in this list are prefixed SYSDEF-
553
554(defvar *system-definition-search-functions*
555  '(sysdef-central-registry-search))
556
557(defun system-definition-pathname (system)
558  (let ((system-name (coerce-name system)))
559    (or
560     (some (lambda (x) (funcall x system-name))
561           *system-definition-search-functions*)
562     (let ((system-pair (system-registered-p system-name)))
563       (and system-pair
564            (system-source-file (cdr system-pair)))))))
565
566(defvar *central-registry*
567  `((directory-namestring *default-pathname-defaults*))
568"A list of 'system directory designators' ASDF uses to find systems.
569
570A 'system directory designator' is a pathname or a function
571which evaluates to a pathname. For example:
572
573    (setf asdf:*central-registry*
574          (list '*default-pathname-defaults*
575                #p\"/home/me/cl/systems/\"
576                #p\"/usr/share/common-lisp/systems/\"))
577")
578
579(defun directory-pathname-p (pathname)
580  "Does `pathname` represent a directory?
581
582A directory-pathname is a pathname _without_ a filename. The three
583ways that the filename components can be missing are for it to be `nil`,
584`:unspecific` or the empty string.
585
586Note that this does _not_ check to see that `pathname` points to an
587actually-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;;test
596;;?? move into testsuite sometime soon
597(every (lambda (p)
598          (directory-pathname-p p))
599        (list 
600         (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      pathname
613      (make-pathname :defaults pathname
614                     :directory (append
615                                 (pathname-directory pathname)
616                                 (list (file-namestring pathname)))
617                     :name nil :type nil :version nil)))
618
619(defun sysdef-central-registry-search (system)
620  (let ((name (coerce-name system))
621        (to-remove nil)
622        (to-replace nil))
623    (block nil
624      (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 ~
650to `~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))))))))))
672
673(defun make-temporary-package ()
674  (flet ((try (counter)
675           (ignore-errors
676             (make-package (format nil "~a~D" 'asdf counter)
677                           :use '(:cl :asdf)))))
678    (do* ((counter 0 (+ counter 1))
679          (package (try counter) (try counter)))
680         (package package))))
681
682(defun find-system (name &optional (error-p t))
683  (let* ((name (coerce-name name))
684         (in-memory (system-registered-p name))
685         (on-disk (system-definition-pathname name)))
686    (when (and on-disk
687               (or (not in-memory)
688                   (< (car in-memory) (file-write-date on-disk))))
689      (let ((package (make-temporary-package)))
690        (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))
699          (delete-package package))))
700    (let ((in-memory (system-registered-p name)))
701      (if in-memory
702          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
703                 (cdr in-memory))
704          (if error-p (error 'missing-component :requires name))))))
705
706(defun register-system (name system)
707  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
708  (setf (gethash (coerce-name name) *defined-systems*)
709        (cons (get-universal-time) system)))
710
711
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)))
726
727;;; component subclasses
728
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) ())
734(defclass static-file (source-file) ())
735(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
762
763(defclass operation ()
764  ((forced :initform nil :initarg :force :accessor operation-forced)
765   (original-initargs :initform nil :initarg :original-initargs
766                      :accessor operation-original-initargs)
767   (visited-nodes :initform nil :accessor operation-visited-nodes)
768   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
769   (parent :initform nil :initarg :parent :accessor operation-parent)))
770
771(defmethod print-object ((o operation) stream)
772  (print-unreadable-object (o stream :type t :identity t)
773    (ignore-errors
774      (prin1 (operation-original-initargs o) stream))))
775
776(defmethod shared-initialize :after ((operation operation) slot-names
777                                     &key force
778                                     &allow-other-keys)
779  (declare (ignore slot-names force))
780  ;; empty method to disable initarg validity checking
781  )
782
783(defun node-for (o c)
784  (cons (class-name (class-of o)) c))
785
786(defmethod operation-ancestor ((operation operation))
787  (aif (operation-parent operation)
788       (operation-ancestor it)
789       operation))
790
791
792(defun make-sub-operation (c o dep-c dep-o)
793  (let* ((args (copy-list (operation-original-initargs o)))
794         (force-p (getf args :force)))
795    ;; note explicit comparison with T: any other non-NIL force value
796    ;; (e.g. :recursive) will pass through
797    (cond ((and (null (component-parent c))
798                (null (component-parent dep-c))
799                (not (eql c dep-c)))
800           (when (eql force-p t)
801             (setf (getf args :force) nil))
802           (apply #'make-instance dep-o
803                  :parent o
804                  :original-initargs args args))
805          ((subtypep (type-of o) dep-o)
806           o)
807          (t
808           (apply #'make-instance dep-o
809                  :parent o :original-initargs args args)))))
810
811
812(defmethod visit-component ((o operation) (c component) data)
813  (unless (component-visited-p o c)
814    (push (cons (node-for o c) data)
815          (operation-visited-nodes (operation-ancestor o)))))
816
817(defmethod component-visited-p ((o operation) (c component))
818  (assoc (node-for o c)
819         (operation-visited-nodes (operation-ancestor o))
820         :test 'equal))
821
822(defmethod (setf visiting-component) (new-value operation component)
823  ;; MCL complains about unused lexical variables
824  (declare (ignorable new-value operation component)))
825
826(defmethod (setf visiting-component) (new-value (o operation) (c component))
827  (let ((node (node-for o c))
828        (a (operation-ancestor o)))
829    (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)))))
833
834(defmethod component-visiting-p ((o operation) (c component))
835  (let ((node (node-for o c)))
836    (member node (operation-visiting-nodes (operation-ancestor o))
837            :test 'equal)))
838
839(defmethod component-depends-on ((op-spec symbol) (c component))
840  (component-depends-on (make-instance op-spec) c))
841
842(defmethod component-depends-on ((o operation) (c component))
843  (cdr (assoc (class-name (class-of o))
844              (slot-value c 'in-order-to))))
845
846(defmethod component-self-dependencies ((o operation) (c component))
847  (let ((all-deps (component-depends-on o c)))
848    (remove-if-not (lambda (x)
849                     (member (component-name c) (cdr x) :test #'string=))
850                   all-deps)))
851
852(defmethod input-files ((operation operation) (c component))
853  (let ((parent (component-parent c))
854        (self-deps (component-self-dependencies operation c)))
855    (if self-deps
856        (mapcan (lambda (dep)
857                  (destructuring-bind (op name) dep
858                    (output-files (make-instance op)
859                                  (find-component parent name))))
860                self-deps)
861        ;; no previous operations needed?  I guess we work with the
862        ;; original source file, then
863        (list (component-pathname c)))))
864
865(defmethod input-files ((operation operation) (c module)) nil)
866
867(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)))))))))
974      (aif (component-visited-p operation c)
975           (return-from traverse
976             (if (cdr it) (list (cons 'pruned-op c)) nil)))
977      ;; dependencies
978      (if (component-visiting-p operation c)
979          (error 'circular-dependency :components (list c)))
980      (setf (visiting-component operation c) t)
981      (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
1029
1030(defmethod perform ((operation operation) (c source-file))
1031  (sysdef-error
1032   "~@<required method PERFORM not implemented ~
1033    for operation ~A, component ~A~@:>"
1034   (class-of operation) (class-of c)))
1035
1036(defmethod perform ((operation operation) (c module))
1037  nil)
1038
1039(defmethod explain ((operation operation) (component component))
1040  (asdf-message "~&;;; ~A on ~A~%" operation component))
1041
1042;;; compile-op
1043
1044(defclass compile-op (operation)
1045  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
1046   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
1047                :initform *compile-file-warnings-behaviour*)
1048   (on-failure :initarg :on-failure :accessor operation-on-failure
1049               :initform *compile-file-failure-behaviour*)))
1050
1051(defmethod perform :before ((operation compile-op) (c source-file))
1052  (map nil #'ensure-directories-exist (output-files operation c)))
1053
1054(defmethod perform :after ((operation operation) (c component))
1055  (setf (gethash (type-of operation) (component-operation-times c))
1056        (get-universal-time)))
1057
1058;;; perform is required to check output-files to find out where to put
1059;;; its answers, in case it has been overridden for site policy
1060(defmethod perform ((operation compile-op) (c cl-source-file))
1061  #-:broken-fasl-loader
1062  (let ((source-file (component-pathname c))
1063        (output-file (car (output-files operation c))))
1064    (multiple-value-bind (output warnings-p failure-p)
1065        (compile-file source-file :output-file output-file)
1066      (when warnings-p
1067        (case (operation-on-warnings operation)
1068          (:warn (warn
1069                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
1070                  operation c))
1071          (:error (error 'compile-warned :component c :operation operation))
1072          (:ignore nil)))
1073      (when failure-p
1074        (case (operation-on-failure operation)
1075          (:warn (warn
1076                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
1077                  operation c))
1078          (:error (error 'compile-failed :component c :operation operation))
1079          (:ignore nil)))
1080      (unless output
1081        (error 'compile-error :component c :operation operation)))))
1082
1083(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)))
1086
1087(defmethod perform ((operation compile-op) (c static-file))
1088  nil)
1089
1090(defmethod output-files ((operation compile-op) (c static-file))
1091  nil)
1092
1093(defmethod input-files ((op compile-op) (c static-file))
1094  nil)
1095
1096
1097;;; load-op
1098
1099(defclass basic-load-op (operation) ())
1100
1101(defclass load-op (basic-load-op) ())
1102
1103(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)))))))
1145
1146(defmethod perform ((operation load-op) (c static-file))
1147  nil)
1148
1149(defmethod operation-done-p ((operation load-op) (c static-file))
1150  t)
1151
1152(defmethod output-files ((o operation) (c component))
1153  nil)
1154
1155(defmethod component-depends-on ((operation load-op) (c component))
1156  (cons (list 'compile-op (component-name c))
1157        (call-next-method)))
1158
1159;;; load-source-op
1160
1161(defclass load-source-op (basic-load-op) ())
1162
1163(defmethod perform ((o load-source-op) (c cl-source-file))
1164  (let ((source (component-pathname c)))
1165    (setf (component-property c 'last-loaded-as-source)
1166          (and (load source)
1167               (get-universal-time)))))
1168
1169(defmethod perform ((operation load-source-op) (c static-file))
1170  nil)
1171
1172(defmethod output-files ((operation load-source-op) (c component))
1173  nil)
1174
1175;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
1176(defmethod component-depends-on ((o load-source-op) (c component))
1177  (let ((what-would-load-op-do (cdr (assoc 'load-op
1178                                           (slot-value c 'in-order-to)))))
1179    (mapcar (lambda (dep)
1180              (if (eq (car dep) 'load-op)
1181                  (cons 'load-source-op (cdr dep))
1182                  dep))
1183            what-would-load-op-do)))
1184
1185(defmethod operation-done-p ((o load-source-op) (c source-file))
1186  (if (or (not (component-property c 'last-loaded-as-source))
1187          (> (file-write-date (component-pathname c))
1188             (component-property c 'last-loaded-as-source)))
1189      nil t))
1190
1191(defclass test-op (operation) ())
1192
1193(defmethod perform ((operation test-op) (c component))
1194  nil)
1195
1196(defmethod operation-done-p ((operation test-op) (c system))
1197  "Testing a system is _never_ done."
1198  nil)
1199
1200(defmethod component-depends-on :around ((o test-op) (c system))
1201  (cons `(load-op ,(component-name c)) (call-next-method)))
1202
1203
1204;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1205;;; invoking operations
1206
1207(defun operate (operation-class system &rest args &key (verbose t) version force
1208                &allow-other-keys)
1209  (declare (ignore force))
1210  (let* ((*package* *package*)
1211         (*readtable* *readtable*)
1212         (op (apply #'make-instance operation-class
1213                    :original-initargs args
1214                    args))
1215         (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
1216         (system (if (typep system 'component) system (find-system system))))
1217    (unless (version-satisfies system version)
1218      (error 'missing-component-of-version :requires system :version version))
1219    (let ((steps (traverse op system)))
1220      (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 ~
1235                                   having been successful.~@:>"
1236                                 op component))
1237                       (setf (gethash (type-of op)
1238                                      (component-operation-times component))
1239                             (get-universal-time))
1240                       (return)))))))
1241    op))
1242
1243(defun oos (operation-class system &rest args &key force (verbose t) version
1244            &allow-other-keys)
1245  (declare (ignore force verbose version))
1246  (apply #'operate operation-class system args))
1247
1248(let ((operate-docstring
1249  "Operate does three things:
1250
12511. It creates an instance of `operation-class` using any keyword parameters
1252as initargs.
12532. It finds the  asdf-system specified by `system` (possibly loading
1254it from disk).
12553. It then calls `traverse` with the operation and system as arguments
1256
1257The traverse operation is wrapped in `with-compilation-unit` and error
1258handling code. If a `version` argument is supplied, then operate also
1259ensures that the system found satisfies it using the `version-satisfies`
1260method.
1261
1262Note that dependencies may cause the operation to invoke other
1263operations on the system or its components: the new operations will be
1264created with the same initargs as the original one.
1265"))
1266  (setf (documentation 'oos 'function)
1267        (format nil
1268                "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
1269                operate-docstring))
1270  (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."
1275  (declare (ignore force verbose version))
1276  (apply #'operate 'load-op system args))
1277
1278(defun compile-system (system &rest args &key force (verbose t) version)
1279  "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details."
1280  (declare (ignore force verbose version))
1281  (apply #'operate 'compile-op system args))
1282
1283(defun test-system (system &rest args &key force (verbose t) version)
1284  "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details."
1285  (declare (ignore force verbose version))
1286  (apply #'operate 'test-op system args))
1287
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  )
1304
1305(defun determine-system-pathname (pathname pathname-supplied-p)
1306  ;; called from the defsystem macro.
1307  ;; the pathname of a system is either
1308  ;; 1. the one supplied,
1309  ;; 2. derived from the *load-truename* (see below), or
1310  ;; 3. taken from *default-pathname-defaults*
1311  ;;
1312  ;; if using *load-truename*, then we also deal with whether or not
1313  ;; to resolve symbolic links. If not resolving symlinks, then we use
1314  ;; *load-pathname* instead of *load-truename* since in some
1315  ;; 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*))
1323
1324(defmacro defsystem (name &body options)
1325  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
1326                            &allow-other-keys)
1327      options
1328    (let ((component-options (remove-keyword :class options)))
1329      `(progn
1330         ;; system must be registered before we parse the body, otherwise
1331         ;; we recur when trying to find an existing system of the same name
1332         ;; to reuse options (e.g. pathname) from
1333         (let ((s (system-registered-p ',name)))
1334           (cond ((and s (eq (type-of (cdr s)) ',class))
1335                  (setf (car s) (get-universal-time)))
1336                 (s
1337                  (change-class (cdr s) ',class))
1338                 (t
1339                  (register-system (quote ,name)
1340                                   (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))))))
1350
1351
1352(defun class-for-type (parent type)
1353  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
1354                              (find-symbol (symbol-name type)
1355                                           (load-time-value
1356                                            (package-name :asdf)))))
1357         (class (dolist (symbol (if (keywordp type)
1358                                    extra-symbols
1359                                    (cons type extra-symbols)))
1360                  (when (and symbol
1361                             (find-class symbol nil)
1362                             (subtypep symbol 'component))
1363                    (return (find-class symbol))))))
1364    (or class
1365        (and (eq type :file)
1366             (or (module-default-component-class parent)
1367                 (find-class 'cl-source-file)))
1368        (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
1369
1370(defun maybe-add-tree (tree op1 op2 c)
1371  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
1372Returns the new tree (which probably shares structure with the old one)"
1373  (let ((first-op-tree (assoc op1 tree)))
1374    (if first-op-tree
1375        (progn
1376          (aif (assoc op2 (cdr first-op-tree))
1377               (if (find c (cdr it))
1378                   nil
1379                   (setf (cdr it) (cons c (cdr it))))
1380               (setf (cdr first-op-tree)
1381                     (acons op2 (list c) (cdr first-op-tree))))
1382          tree)
1383        (acons op1 (list (list op2 c)) tree))))
1384
1385(defun union-of-dependencies (&rest deps)
1386  (let ((new-tree nil))
1387    (dolist (dep deps)
1388      (dolist (op-tree dep)
1389        (dolist (op  (cdr op-tree))
1390          (dolist (c (cdr op))
1391            (setf new-tree
1392                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
1393    new-tree))
1394
1395
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*)
1403
1404(defun sysdef-error-component (msg type name value)
1405  (sysdef-error (concatenate 'string msg
1406                             "~&The value specified for ~(~A~) ~A is ~W")
1407                type name value))
1408
1409(defun check-component-input (type name weakly-depends-on 
1410                              depends-on components in-order-to)
1411  "A partial test of the values of a component."
1412  (unless (listp depends-on)
1413    (sysdef-error-component ":depends-on must be a list."
1414                            type name depends-on))
1415  (unless (listp weakly-depends-on)
1416    (sysdef-error-component ":weakly-depends-on must be a list."
1417                            type name weakly-depends-on))
1418  (unless (listp components)
1419    (sysdef-error-component ":components must be NIL or a list of components."
1420                            type name components))
1421  (unless (and (listp in-order-to) (listp (car in-order-to)))
1422    (sysdef-error-component ":in-order-to must be NIL or a list of components."
1423                            type name in-order-to)))
1424
1425(defun %remove-component-inline-methods (component)
1426  (loop for name in +asdf-methods+
1427        do (map 'nil
1428                ;; this is inefficient as most of the stored
1429                ;; methods will not be for this particular gf n
1430                ;; But this is hardly performance-critical
1431                (lambda (m)
1432                  (remove-method (symbol-function name) m))
1433                (component-inline-methods component)))
1434  ;; clear methods, then add the new ones
1435  (setf (component-inline-methods component) nil))
1436
1437(defun %define-component-inline-methods (ret rest)
1438  (loop for name in +asdf-methods+ do
1439       (let ((keyword (intern (symbol-name name) :keyword)))
1440         (loop for data = rest then (cddr data)
1441              for key = (first data)
1442              for value = (second data)
1443              while data
1444              when (eq key keyword) do
1445              (destructuring-bind (op qual (o c) &body body) value
1446              (pushnew
1447                 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
1448                                   ,@body))
1449                 (component-inline-methods ret)))))))
1450
1451(defun %refresh-component-inline-methods (component rest)
1452  (%remove-component-inline-methods component)
1453  (%define-component-inline-methods component rest))
1454 
1455(defun parse-component-form (parent options)
1456
1457  (destructuring-bind
1458        (type name &rest rest &key
1459              ;; the following list of keywords is reproduced below in the
1460              ;; remove-keys form.  important to keep them in sync
1461              components pathname default-component-class
1462              perform explain output-files operation-done-p
1463              weakly-depends-on
1464              depends-on serial in-order-to
1465              ;; list ends
1466              &allow-other-keys) options
1467    (declare (ignorable perform explain output-files operation-done-p))
1468    (check-component-input type name weakly-depends-on depends-on components in-order-to)
1469
1470    (when (and parent
1471               (find-component parent name)
1472               ;; ignore the same object when rereading the defsystem
1473               (not
1474                (typep (find-component parent name)
1475                       (class-for-type parent type))))
1476      (error 'duplicate-names :name name))
1477
1478    (let* ((other-args (remove-keys
1479                        '(components pathname default-component-class
1480                          perform explain output-files operation-done-p
1481                          weakly-depends-on
1482                          depends-on serial in-order-to)
1483                        rest))
1484           (ret
1485            (or (find-component parent name)
1486                (make-instance (class-for-type parent type)))))
1487      (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)))
1492      (apply #'reinitialize-instance ret
1493             :name (coerce-name name)
1494             :pathname pathname
1495             :parent parent
1496             other-args)
1497      (when (typep ret 'module)
1498        (setf (module-default-component-class ret)
1499              (or default-component-class
1500                  (and (typep parent 'module)
1501                       (module-default-component-class parent))))
1502        (let ((*serial-depends-on* nil))
1503          (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)
1523            (union-of-dependencies
1524             in-order-to
1525             `((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))))
1528
1529      (%refresh-component-inline-methods ret rest)
1530
1531      ret)))
1532
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
1538
1539(defun run-shell-command (control-string &rest args)
1540  "Interpolate `args` into `control-string` as if by `format`, and
1541synchronously execute the result using a Bourne-compatible shell, with
1542output to `*verbose-out*`.  Returns the shell's exit code."
1543  (let ((command (apply #'format nil control-string args)))
1544    (asdf-message "; $ ~A~%" command)
1545    #+sbcl
1546    (sb-ext:process-exit-code
1547     (apply #'sb-ext:run-program
1548            #+win32 "sh" #-win32 "/bin/sh"
1549            (list  "-c" command)
1550            :input nil :output *verbose-out*
1551            #+win32 '(:search t) #-win32 nil))
1552
1553    #+(or cmu scl)
1554    (ext:process-exit-code
1555     (ext:run-program
1556      "/bin/sh"
1557      (list  "-c" command)
1558      :input nil :output *verbose-out*))
1559
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))
1596  (system-source-file (find-system system-name)))
1597
1598(defun system-source-directory (system-name)
1599  (make-pathname :name nil
1600                 :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))))
1613
1614;;; ---------------------------------------------------------------------------
1615;;; asdf-binary-locations
1616;;;
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 "
1625If 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
1628without an explicitly mapping will be placed in subdirectories of
1629their sources.")
1630
1631(defparameter *enable-asdf-binary-locations* nil
1632  "
1633If true, then compiled lisp files will be placed into a directory
1634computed from the Lisp version, Operating System and computer archetecture.
1635See [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")
1666
1667(defparameter *implementation-features*
1668  '(:allegro :lispworks :sbcl :ccl :openmcl :cmu :clisp
1669    :corman :cormanlisp :armedbear :gcl :ecl :scl))
1670
1671(defparameter *os-features*
1672  '(:windows :mswindows :win32 :mingw32
1673    :solaris :sunos
1674    :macosx :darwin :apple
1675    :freebsd :netbsd :openbsd :bsd
1676    :linux :unix))
1677
1678(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
1684(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
1703                      "~A~A~A~A"
1704                      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 ""))
1715                      (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
1727unique to a Lisp implementation, Lisp implementation version,
1728operating 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 ~
1762                                          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
1777by resolving sources that are symlinks.
1778
1779As ASDF sometimes resolves symlinks to compute source paths, we must
1780follow that.  For example, if SBCL is installed under a symlink, and
1781SBCL_HOME is set through that symlink, the default rule above
1782preventing SBCL contribs from being mapped elsewhere will not be
1783applied 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)))
1849
1850;;;; -----------------------------------------------------------------
1851;;;; Windows shortcut support.  Based on:
1852;;;;
1853;;;; Jesse Hager: The Windows Shortcut File Format.
1854;;;; http://www.wotsit.org/list.asp?fc=13
1855;;;; -----------------------------------------------------------------
1856
1857(defparameter *link-initial-dword* 76)
1858(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1859
1860(defun read-null-terminated-string (s)
1861  (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))))
1866
1867(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))
1874
1875(defun parse-windows-shortcut (pathname)
1876  (with-open-file (s pathname :element-type '(unsigned-byte 8))
1877    (handler-case
1878        (when (and (= (read-little-endian s) *link-initial-dword*)
1879                   (let ((header (make-array (length *link-guid*))))
1880                     (read-sequence header s)
1881                     (equalp header *link-guid*)))
1882          (let ((flags (read-little-endian s)))
1883            (file-position s 76)        ;skip rest of header
1884            (when (logbitp 0 flags)
1885              ;; skip shell item id list
1886              (let ((length (read-little-endian s 2)))
1887                (file-position s (+ length (file-position s)))))
1888            (cond
1889              ((logbitp 1 flags)
1890                (parse-file-location-info s))
1891              (t
1892                (when (logbitp 2 flags)
1893                  ;; skip description string
1894                  (let ((length (read-little-endian s 2)))
1895                    (file-position s (+ length (file-position s)))))
1896                (when (logbitp 3 flags)
1897                  ;; finally, our pathname
1898                  (let* ((length (read-little-endian s 2))
1899                         (buffer (make-array length)))
1900                    (read-sequence buffer s)
1901                    (map 'string #'code-char buffer)))))))
1902      (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)
1938(progn
1939  (defun module-provide-asdf (name)
1940    (handler-bind ((style-warning #'muffle-warning))
1941      (let* ((*verbose-out* (make-broadcast-stream))
1942             (system (asdf:find-system name nil)))
1943        (when system
1944          (asdf:operate 'asdf:load-op name)
1945          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)))
Note: See TracBrowser for help on using the repository browser.