source: trunk/source/tools/asdf.lisp @ 11305

Last change on this file since 11305 was 11305, checked in by gz, 12 years ago

Update to asdf 1.130

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 52.8 KB
Line 
1;;; This is asdf: Another System Definition Facility.  $Revision: 11305 $
2;;;
3;;; Feedback, bug reports, and patches are all welcome: please mail to
4;;; <cclan-list@lists.sf.net>.  But note first that the canonical
5;;; source for asdf is presently the cCLan CVS repository at
6;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
7;;;
8;;; If you obtained this copy from anywhere else, and you experience
9;;; trouble using it, or find bugs, you may want to check at the
10;;; location above for a more recent version (and for documentation
11;;; and test files, if your copy came without them) before reporting
12;;; bugs.  There are usually two "supported" revisions - the CVS HEAD
13;;; is the latest development version, whereas the revision tagged
14;;; RELEASE may be slightly older but is considered `stable'
15
16;;; Copyright (c) 2001-2008 Daniel Barlow and contributors
17;;;
18;;; Permission is hereby granted, free of charge, to any person obtaining
19;;; a copy of this software and associated documentation files (the
20;;; "Software"), to deal in the Software without restriction, including
21;;; without limitation the rights to use, copy, modify, merge, publish,
22;;; distribute, sublicense, and/or sell copies of the Software, and to
23;;; permit persons to whom the Software is furnished to do so, subject to
24;;; the following conditions:
25;;;
26;;; The above copyright notice and this permission notice shall be
27;;; included in all copies or substantial portions of the Software.
28;;;
29;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
30;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
31;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
32;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
33;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
34;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
35;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
36
37;;; the problem with writing a defsystem replacement is bootstrapping:
38;;; we can't use defsystem to compile it.  Hence, all in one file
39
40(defpackage #:asdf
41  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
42           #:system-definition-pathname #:find-component ; miscellaneous
43
44           #:compile-op #:load-op #:load-source-op 
45           #:test-op
46           #:operation           ; operations
47           #:feature             ; sort-of operation
48           #:version             ; metaphorically sort-of an operation
49
50           #:input-files #:output-files #:perform ; operation methods
51           #:operation-done-p #:explain
52
53           #:component #:source-file
54           #:c-source-file #:cl-source-file #:java-source-file
55           #:static-file
56           #:doc-file
57           #:html-file
58           #:text-file
59           #:source-file-type
60           #:module                     ; components
61           #:system
62           #:unix-dso
63
64           #:module-components          ; component accessors
65           #:component-pathname
66           #:component-relative-pathname
67           #:component-name
68           #:component-version
69           #:component-parent
70           #:component-property
71           #:component-system
72
73           #:component-depends-on
74
75           #:system-description
76           #:system-long-description
77           #:system-author
78           #:system-maintainer
79           #:system-license
80           #:system-licence
81           #:system-source-file
82           #:system-relative-pathname
83
84           #:operation-on-warnings
85           #:operation-on-failure
86
87                                        ;#:*component-parent-pathname*
88           #:*system-definition-search-functions*
89           #:*central-registry*         ; variables
90           #:*compile-file-warnings-behaviour*
91           #:*compile-file-failure-behaviour*
92           #:*asdf-revision*
93
94           #:operation-error #:compile-failed #:compile-warned #:compile-error
95           #:error-component #:error-operation
96           #:system-definition-error
97           #:missing-component
98           #:missing-component-of-version
99           #:missing-dependency
100           #:missing-dependency-of-version
101           #:circular-dependency        ; errors
102           #:duplicate-names
103
104           #:try-recompiling
105           #:retry
106           #:accept                     ; restarts
107
108           #:standard-asdf-method-combination
109           #:around                     ; protocol assistants
110           )
111  (:use :cl))
112
113
114#+nil
115(error "The author of this file habitually uses #+nil to comment out ~
116        forms. But don't worry, it was unlikely to work in the New ~
117        Implementation of Lisp anyway")
118
119(in-package #:asdf)
120
121(defvar *asdf-revision* (let* ((v "$Revision: 11305 $")
122                               (colon (or (position #\: v) -1))
123                               (dot (position #\. v)))
124                          (and v colon dot
125                               (list (parse-integer v :start (1+ colon)
126                                                      :junk-allowed t)
127                                     (parse-integer v :start (1+ dot)
128                                                      :junk-allowed t)))))
129
130(defvar *compile-file-warnings-behaviour* :warn)
131
132(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
133
134(defvar *verbose-out* nil)
135
136(defparameter +asdf-methods+
137  '(perform explain output-files operation-done-p))
138
139;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
140;; utility stuff
141
142(defmacro aif (test then &optional else)
143  `(let ((it ,test)) (if it ,then ,else)))
144
145(defun pathname-sans-name+type (pathname)
146  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
147and NIL NAME and TYPE components"
148  (make-pathname :name nil :type nil :defaults pathname))
149
150(define-modify-macro appendf (&rest args)
151  append "Append onto list")
152
153;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154;; classes, condiitons
155
156(define-condition system-definition-error (error) ()
157  ;; [this use of :report should be redundant, but unfortunately it's not.
158  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
159  ;; over print-object; this is always conditions::%print-condition for
160  ;; condition objects, which in turn does inheritance of :report options at
161  ;; run-time.  fortunately, inheritance means we only need this kludge here in
162  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
163  #+cmu (:report print-object))
164
165(define-condition formatted-system-definition-error (system-definition-error)
166  ((format-control :initarg :format-control :reader format-control)
167   (format-arguments :initarg :format-arguments :reader format-arguments))
168  (:report (lambda (c s)
169             (apply #'format s (format-control c) (format-arguments c)))))
170
171(define-condition circular-dependency (system-definition-error)
172  ((components :initarg :components :reader circular-dependency-components)))
173
174(define-condition duplicate-names (system-definition-error)
175  ((name :initarg :name :reader duplicate-names-name)))
176
177(define-condition missing-component (system-definition-error)
178  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
179   (parent :initform nil :reader missing-parent :initarg :parent)))
180
181(define-condition missing-component-of-version (missing-component)
182  ((version :initform nil :reader missing-version :initarg :version)))
183
184(define-condition missing-dependency (missing-component)
185  ((required-by :initarg :required-by :reader missing-required-by)))
186
187(define-condition missing-dependency-of-version (missing-dependency
188                                                 missing-component-of-version)
189  ())
190
191(define-condition operation-error (error)
192  ((component :reader error-component :initarg :component)
193   (operation :reader error-operation :initarg :operation))
194  (:report (lambda (c s)
195             (format s "~@<erred while invoking ~A on ~A~@:>"
196                     (error-operation c) (error-component c)))))
197(define-condition compile-error (operation-error) ())
198(define-condition compile-failed (compile-error) ())
199(define-condition compile-warned (compile-error) ())
200
201(defclass component ()
202  ((name :accessor component-name :initarg :name :documentation
203         "Component name: designator for a string composed of portable pathname characters")
204   (version :accessor component-version :initarg :version)
205   (in-order-to :initform nil :initarg :in-order-to)
206   ;; XXX crap name
207   (do-first :initform nil :initarg :do-first)
208   ;; methods defined using the "inline" style inside a defsystem form:
209   ;; need to store them somewhere so we can delete them when the system
210   ;; is re-evaluated
211   (inline-methods :accessor component-inline-methods :initform nil)
212   (parent :initarg :parent :initform nil :reader component-parent)
213   ;; no direct accessor for pathname, we do this as a method to allow
214   ;; it to default in funky ways if not supplied
215   (relative-pathname :initarg :pathname)
216   (operation-times :initform (make-hash-table )
217                    :accessor component-operation-times)
218   ;; XXX we should provide some atomic interface for updating the
219   ;; component properties
220   (properties :accessor component-properties :initarg :properties
221               :initform nil)))
222
223;;;; methods: conditions
224
225(defmethod print-object ((c missing-dependency) s)
226  (format s "~@<~A, required by ~A~@:>"
227          (call-next-method c nil) (missing-required-by c)))
228
229(defun sysdef-error (format &rest arguments)
230  (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
231
232;;;; methods: components
233
234(defmethod print-object ((c missing-component) s)
235   (format s "~@<component ~S not found~
236             ~@[ in ~A~]~@:>"
237          (missing-requires c)
238          (when (missing-parent c)
239            (component-name (missing-parent c)))))
240
241(defmethod print-object ((c missing-component-of-version) s)
242  (format s "~@<component ~S does not match version ~A~
243              ~@[ in ~A~]~@:>"
244           (missing-requires c)
245           (missing-version c)
246           (when (missing-parent c)
247             (component-name (missing-parent c)))))
248
249(defgeneric component-system (component)
250  (:documentation "Find the top-level system containing COMPONENT"))
251
252(defmethod component-system ((component component))
253  (aif (component-parent component)
254       (component-system it)
255       component))
256
257(defmethod print-object ((c component) stream)
258  (print-unreadable-object (c stream :type t :identity t)
259    (ignore-errors
260      (prin1 (component-name c) stream))))
261
262(defclass module (component)
263  ((components :initform nil :accessor module-components :initarg :components)
264   ;; what to do if we can't satisfy a dependency of one of this module's
265   ;; components.  This allows a limited form of conditional processing
266   (if-component-dep-fails :initform :fail
267                           :accessor module-if-component-dep-fails
268                           :initarg :if-component-dep-fails)
269   (default-component-class :accessor module-default-component-class
270     :initform 'cl-source-file :initarg :default-component-class)))
271
272(defgeneric component-pathname (component)
273  (:documentation "Extracts the pathname applicable for a particular component."))
274
275(defun component-parent-pathname (component)
276  (aif (component-parent component)
277       (component-pathname it)
278       *default-pathname-defaults*))
279
280(defgeneric component-relative-pathname (component)
281  (:documentation "Extracts the relative pathname applicable for a particular component."))
282
283(defmethod component-relative-pathname ((component module))
284  (or (slot-value component 'relative-pathname)
285      (make-pathname
286       :directory `(:relative ,(component-name component))
287       :host (pathname-host (component-parent-pathname component)))))
288
289(defmethod component-pathname ((component component))
290  (let ((*default-pathname-defaults* (component-parent-pathname component)))
291    (merge-pathnames (component-relative-pathname component))))
292
293(defgeneric component-property (component property))
294
295(defmethod component-property ((c component) property)
296  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
297
298(defgeneric (setf component-property) (new-value component property))
299
300(defmethod (setf component-property) (new-value (c component) property)
301  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
302    (if a
303        (setf (cdr a) new-value)
304        (setf (slot-value c 'properties)
305              (acons property new-value (slot-value c 'properties))))))
306
307(defclass system (module)
308  ((description :accessor system-description :initarg :description)
309   (long-description
310    :accessor system-long-description :initarg :long-description)
311   (author :accessor system-author :initarg :author)
312   (maintainer :accessor system-maintainer :initarg :maintainer)
313   (licence :accessor system-licence :initarg :licence
314            :accessor system-license :initarg :license)))
315
316;;; version-satisfies
317
318;;; with apologies to christophe rhodes ...
319(defun split (string &optional max (ws '(#\Space #\Tab)))
320  (flet ((is-ws (char) (find char ws)))
321    (nreverse
322     (let ((list nil) (start 0) (words 0) end)
323       (loop
324         (when (and max (>= words (1- max)))
325           (return (cons (subseq string start) list)))
326         (setf end (position-if #'is-ws string :start start))
327         (push (subseq string start end) list)
328         (incf words)
329         (unless end (return list))
330         (setf start (1+ end)))))))
331
332(defgeneric version-satisfies (component version))
333
334(defmethod version-satisfies ((c component) version)
335  (unless (and version (slot-boundp c 'version))
336    (return-from version-satisfies t))
337  (let ((x (mapcar #'parse-integer
338                   (split (component-version c) nil '(#\.))))
339        (y (mapcar #'parse-integer
340                   (split version nil '(#\.)))))
341    (labels ((bigger (x y)
342               (cond ((not y) t)
343                     ((not x) nil)
344                     ((> (car x) (car y)) t)
345                     ((= (car x) (car y))
346                      (bigger (cdr x) (cdr y))))))
347      (and (= (car x) (car y))
348           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
349
350;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
351;;; finding systems
352
353(defvar *defined-systems* (make-hash-table :test 'equal))
354(defun coerce-name (name)
355  (typecase name
356    (component (component-name name))
357    (symbol (string-downcase (symbol-name name)))
358    (string name)
359    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
360
361;;; for the sake of keeping things reasonably neat, we adopt a
362;;; convention that functions in this list are prefixed SYSDEF-
363
364(defvar *system-definition-search-functions*
365  '(sysdef-central-registry-search))
366
367(defun system-definition-pathname (system)
368  (let ((system-name (coerce-name system)))
369    (or
370     (some (lambda (x) (funcall x system-name))
371           *system-definition-search-functions*)
372     (let ((system-pair (system-registered-p system-name)))
373       (and system-pair
374            (system-source-file (cdr system-pair)))))))
375
376(defvar *central-registry*
377  '(*default-pathname-defaults*
378    #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
379    #+nil "telent:asdf;systems;"))
380
381(defun sysdef-central-registry-search (system)
382  (let ((name (coerce-name system)))
383    (block nil
384      (dolist (dir *central-registry*)
385        (let* ((defaults (eval dir))
386               (file (and defaults
387                          (make-pathname
388                           :defaults defaults :version :newest
389                           :name name :type "asd" :case :local))))
390          (if (and file (probe-file file))
391              (return file)))))))
392
393(defun make-temporary-package ()
394  (flet ((try (counter)
395           (ignore-errors
396             (make-package (format nil "ASDF~D" counter)
397                           :use '(:cl :asdf)))))
398    (do* ((counter 0 (+ counter 1))
399          (package (try counter) (try counter)))
400         (package package))))
401
402(defun find-system (name &optional (error-p t))
403  (let* ((name (coerce-name name))
404         (in-memory (system-registered-p name))
405         (on-disk (system-definition-pathname name)))
406    (when (and on-disk
407               (or (not in-memory)
408                   (< (car in-memory) (file-write-date on-disk))))
409      (let ((package (make-temporary-package)))
410        (unwind-protect
411             (let ((*package* package))
412               (format
413                *verbose-out*
414                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
415                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
416                ;; ON-DISK), but CMUCL barfs on that.
417                on-disk
418                *package*)
419               (load on-disk))
420          (delete-package package))))
421    (let ((in-memory (system-registered-p name)))
422      (if in-memory
423          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
424                 (cdr in-memory))
425          (if error-p (error 'missing-component :requires name))))))
426
427(defun register-system (name system)
428  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
429  (setf (gethash (coerce-name name) *defined-systems*)
430        (cons (get-universal-time) system)))
431
432(defun system-registered-p (name)
433  (gethash (coerce-name name) *defined-systems*))
434
435
436;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
437;;; finding components
438
439(defgeneric find-component (module name &optional version)
440  (:documentation "Finds the component with name NAME present in the
441MODULE module; if MODULE is nil, then the component is assumed to be a
442system."))
443
444(defmethod find-component ((module module) name &optional version)
445  (if (slot-boundp module 'components)
446      (let ((m (find name (module-components module)
447                     :test #'equal :key #'component-name)))
448        (if (and m (version-satisfies m version)) m))))
449
450
451;;; a component with no parent is a system
452(defmethod find-component ((module (eql nil)) name &optional version)
453  (let ((m (find-system name nil)))
454    (if (and m (version-satisfies m version)) m)))
455
456;;; component subclasses
457
458(defclass source-file (component) ())
459
460(defclass cl-source-file (source-file) ())
461(defclass c-source-file (source-file) ())
462(defclass java-source-file (source-file) ())
463(defclass static-file (source-file) ())
464(defclass doc-file (static-file) ())
465(defclass html-file (doc-file) ())
466
467(defgeneric source-file-type (component system))
468(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
469(defmethod source-file-type ((c c-source-file) (s module)) "c")
470(defmethod source-file-type ((c java-source-file) (s module)) "java")
471(defmethod source-file-type ((c html-file) (s module)) "html")
472(defmethod source-file-type ((c static-file) (s module)) nil)
473
474(defmethod component-relative-pathname ((component source-file))
475  (let ((relative-pathname (slot-value component 'relative-pathname)))
476    (if relative-pathname
477        (merge-pathnames
478         relative-pathname
479         (make-pathname
480          :type (source-file-type component (component-system component))))
481        (let* ((*default-pathname-defaults*
482                (component-parent-pathname component))
483               (name-type
484                (make-pathname
485                 :name (component-name component)
486                 :type (source-file-type component
487                                         (component-system component)))))
488          name-type))))
489
490;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
491;;; operations
492
493;;; one of these is instantiated whenever (operate ) is called
494
495(defclass operation ()
496  ((forced :initform nil :initarg :force :accessor operation-forced)
497   (original-initargs :initform nil :initarg :original-initargs
498                      :accessor operation-original-initargs)
499   (visited-nodes :initform nil :accessor operation-visited-nodes)
500   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
501   (parent :initform nil :initarg :parent :accessor operation-parent)))
502
503(defmethod print-object ((o operation) stream)
504  (print-unreadable-object (o stream :type t :identity t)
505    (ignore-errors
506      (prin1 (operation-original-initargs o) stream))))
507
508(defmethod shared-initialize :after ((operation operation) slot-names
509                                     &key force
510                                     &allow-other-keys)
511  (declare (ignore slot-names force))
512  ;; empty method to disable initarg validity checking
513  )
514
515(define-method-combination standard-asdf-method-combination ()
516  ((around-asdf (around))
517   (around (:around))
518   (before (:before))
519   (primary () :required t)
520   (after (:after)))
521  (flet ((call-methods (methods)
522           (mapcar #'(lambda (method)
523                       `(call-method ,method))
524                   methods)))
525    (let* ((form (if (or before after (rest primary))
526                     `(multiple-value-prog1
527                          (progn ,@(call-methods before)
528                                 (call-method ,(first primary)
529                                              ,(rest primary)))
530                        ,@(call-methods (reverse after)))
531                     `(call-method ,(first primary))))
532           (standard-form (if around
533                              `(call-method ,(first around)
534                                            (,@(rest around)
535                                               (make-method ,form)))
536                              form)))
537      (if around-asdf
538          `(call-method ,(first around-asdf)
539                        (,@(rest around-asdf) (make-method ,standard-form)))
540          standard-form))))
541
542(defgeneric perform (operation component)
543  (:method-combination standard-asdf-method-combination))
544(defgeneric operation-done-p (operation component)
545  (:method-combination standard-asdf-method-combination))
546(defgeneric explain (operation component)
547  (:method-combination standard-asdf-method-combination))
548(defgeneric output-files (operation component)
549  (:method-combination standard-asdf-method-combination))
550(defgeneric input-files (operation component)
551  (:method-combination standard-asdf-method-combination))
552
553(defun node-for (o c)
554  (cons (class-name (class-of o)) c))
555
556(defgeneric operation-ancestor (operation)
557  (:documentation
558   "Recursively chase the operation's parent pointer until we get to
559the head of the tree"))
560
561(defmethod operation-ancestor ((operation operation))
562  (aif (operation-parent operation)
563       (operation-ancestor it)
564       operation))
565
566
567(defun make-sub-operation (c o dep-c dep-o)
568  (let* ((args (copy-list (operation-original-initargs o)))
569         (force-p (getf args :force)))
570    ;; note explicit comparison with T: any other non-NIL force value
571    ;; (e.g. :recursive) will pass through
572    (cond ((and (null (component-parent c))
573                (null (component-parent dep-c))
574                (not (eql c dep-c)))
575           (when (eql force-p t)
576             (setf (getf args :force) nil))
577           (apply #'make-instance dep-o
578                  :parent o
579                  :original-initargs args args))
580          ((subtypep (type-of o) dep-o)
581           o)
582          (t
583           (apply #'make-instance dep-o
584                  :parent o :original-initargs args args)))))
585
586
587(defgeneric component-visited-p (operation component))
588
589(defgeneric visit-component (operation component data))
590
591(defmethod visit-component ((o operation) (c component) data)
592  (unless (component-visited-p o c)
593    (push (cons (node-for o c) data)
594          (operation-visited-nodes (operation-ancestor o)))))
595
596(defmethod component-visited-p ((o operation) (c component))
597  (assoc (node-for o c)
598         (operation-visited-nodes (operation-ancestor o))
599         :test 'equal))
600
601(defgeneric (setf visiting-component) (new-value operation component))
602
603(defmethod (setf visiting-component) (new-value operation component)
604  ;; MCL complains about unused lexical variables
605  (declare (ignorable new-value operation component)))
606
607(defmethod (setf visiting-component) (new-value (o operation) (c component))
608  (let ((node (node-for o c))
609        (a (operation-ancestor o)))
610    (if new-value
611        (pushnew node (operation-visiting-nodes a) :test 'equal)
612        (setf (operation-visiting-nodes a)
613              (remove node  (operation-visiting-nodes a) :test 'equal)))))
614
615(defgeneric component-visiting-p (operation component))
616
617(defmethod component-visiting-p ((o operation) (c component))
618  (let ((node (node-for o c)))
619    (member node (operation-visiting-nodes (operation-ancestor o))
620            :test 'equal)))
621
622(defgeneric component-depends-on (operation component)
623  (:documentation
624   "Returns a list of dependencies needed by the component to perform
625    the operation.  A dependency has one of the following forms:
626
627      (<operation> <component>*), where <operation> is a class
628        designator and each <component> is a component
629        designator, which means that the component depends on
630        <operation> having been performed on each <component>; or
631
632      (FEATURE <feature>), which means that the component depends
633        on <feature>'s presence in *FEATURES*.
634
635    Methods specialized on subclasses of existing component types
636    should usually append the results of CALL-NEXT-METHOD to the
637    list."))
638
639(defmethod component-depends-on ((op-spec symbol) (c component))
640  (component-depends-on (make-instance op-spec) c))
641
642(defmethod component-depends-on ((o operation) (c component))
643  (cdr (assoc (class-name (class-of o))
644              (slot-value c 'in-order-to))))
645
646(defgeneric component-self-dependencies (operation component))
647
648(defmethod component-self-dependencies ((o operation) (c component))
649  (let ((all-deps (component-depends-on o c)))
650    (remove-if-not (lambda (x)
651                     (member (component-name c) (cdr x) :test #'string=))
652                   all-deps)))
653
654(defmethod input-files ((operation operation) (c component))
655  (let ((parent (component-parent c))
656        (self-deps (component-self-dependencies operation c)))
657    (if self-deps
658        (mapcan (lambda (dep)
659                  (destructuring-bind (op name) dep
660                    (output-files (make-instance op)
661                                  (find-component parent name))))
662                self-deps)
663        ;; no previous operations needed?  I guess we work with the
664        ;; original source file, then
665        (list (component-pathname c)))))
666
667(defmethod input-files ((operation operation) (c module)) nil)
668
669(defmethod operation-done-p ((o operation) (c component))
670  (flet ((fwd-or-return-t (file)
671           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
672           ;; user or some other agent has deleted an input file.  If
673           ;; that's the case, well, that's not good, but as long as
674           ;; the operation is otherwise considered to be done we
675           ;; could continue and survive.
676           (let ((date (file-write-date file)))
677             (cond
678               (date)
679               (t
680                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
681                       operation ~S on component ~S as done.~@:>"
682                      file o c)
683                (return-from operation-done-p t))))))
684    (let ((out-files (output-files o c))
685          (in-files (input-files o c)))
686      (cond ((and (not in-files) (not out-files))
687             ;; arbitrary decision: an operation that uses nothing to
688             ;; produce nothing probably isn't doing much
689             t)
690            ((not out-files)
691             (let ((op-done
692                    (gethash (type-of o)
693                             (component-operation-times c))))
694               (and op-done
695                    (>= op-done
696                        (apply #'max
697                               (mapcar #'fwd-or-return-t in-files))))))
698            ((not in-files) nil)
699            (t
700             (and
701              (every #'probe-file out-files)
702              (> (apply #'min (mapcar #'file-write-date out-files))
703                 (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
704
705;;; So you look at this code and think "why isn't it a bunch of
706;;; methods".  And the answer is, because standard method combination
707;;; runs :before methods most->least-specific, which is back to front
708;;; for our purposes.  And CLISP doesn't have non-standard method
709;;; combinations, so let's keep it simple and aspire to portability
710
711(defgeneric traverse (operation component))
712(defmethod traverse ((operation operation) (c component))
713  (let ((forced nil))
714    (labels ((do-one-dep (required-op required-c required-v)
715               (let* ((dep-c (or (find-component
716                                  (component-parent c)
717                                  ;; XXX tacky.  really we should build the
718                                  ;; in-order-to slot with canonicalized
719                                  ;; names instead of coercing this late
720                                  (coerce-name required-c) required-v)
721                                 (if required-v
722                                     (error 'missing-dependency-of-version
723                                            :required-by c
724                                            :version required-v
725                                            :requires required-c)
726                                     (error 'missing-dependency
727                                            :required-by c
728                                            :requires required-c))))
729                      (op (make-sub-operation c operation dep-c required-op)))
730                 (traverse op dep-c)))
731             (do-dep (op dep)
732               (cond ((eq op 'feature)
733                      (or (member (car dep) *features*)
734                          (error 'missing-dependency
735                                 :required-by c
736                                 :requires (car dep))))
737                     (t
738                      (dolist (d dep)
739                        (cond ((consp d)
740                               (assert (string-equal
741                                        (symbol-name (first d))
742                                        "VERSION"))
743                               (appendf forced
744                                        (do-one-dep op (second d) (third d))))
745                              (t
746                               (appendf forced (do-one-dep op d nil)))))))))
747      (aif (component-visited-p operation c)
748           (return-from traverse
749             (if (cdr it) (list (cons 'pruned-op c)) nil)))
750      ;; dependencies
751      (if (component-visiting-p operation c)
752          (error 'circular-dependency :components (list c)))
753      (setf (visiting-component operation c) t)
754      (unwind-protect
755           (progn
756             (loop for (required-op . deps) in 
757                  (component-depends-on operation c)
758                do (do-dep required-op deps))
759             ;; constituent bits
760             (let ((module-ops
761                    (when (typep c 'module)
762                      (let ((at-least-one nil)
763                            (forced nil)
764                            (error nil))
765                        (loop for kid in (module-components c)
766                           do (handler-case
767                                  (appendf forced (traverse operation kid ))
768                                (missing-dependency (condition)
769                                  (if (eq (module-if-component-dep-fails c) 
770                                          :fail)
771                                      (error condition))
772                                  (setf error condition))
773                                (:no-error (c)
774                                  (declare (ignore c))
775                                  (setf at-least-one t))))
776                        (when (and (eq (module-if-component-dep-fails c)
777                                       :try-next)
778                                   (not at-least-one))
779                          (error error))
780                        forced))))
781               ;; now the thing itself
782               (when (or forced module-ops
783                         (not (operation-done-p operation c))
784                         (let ((f (operation-forced 
785                                   (operation-ancestor operation))))
786                           (and f (or (not (consp f))
787                                      (member (component-name
788                                               (operation-ancestor operation))
789                                              (mapcar #'coerce-name f)
790                                              :test #'string=)))))
791                 (let ((do-first (cdr (assoc (class-name (class-of operation))
792                                             (slot-value c 'do-first)))))
793                   (loop for (required-op . deps) in do-first
794                      do (do-dep required-op deps)))
795                 (setf forced (append (delete 'pruned-op forced :key #'car)
796                                      (delete 'pruned-op module-ops :key #'car)
797                                      (list (cons operation c)))))))
798        (setf (visiting-component operation c) nil))
799      (visit-component operation c (and forced t))
800      forced)))
801
802
803(defmethod perform ((operation operation) (c source-file))
804  (sysdef-error
805   "~@<required method PERFORM not implemented ~
806    for operation ~A, component ~A~@:>"
807   (class-of operation) (class-of c)))
808
809(defmethod perform ((operation operation) (c module))
810  nil)
811
812(defmethod explain ((operation operation) (component component))
813  (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
814
815;;; compile-op
816
817(defclass compile-op (operation)
818  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
819   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
820                :initform *compile-file-warnings-behaviour*)
821   (on-failure :initarg :on-failure :accessor operation-on-failure
822               :initform *compile-file-failure-behaviour*)))
823
824(defmethod perform :before ((operation compile-op) (c source-file))
825  (map nil #'ensure-directories-exist (output-files operation c)))
826
827(defmethod perform :after ((operation operation) (c component))
828  (setf (gethash (type-of operation) (component-operation-times c))
829        (get-universal-time)))
830
831;;; perform is required to check output-files to find out where to put
832;;; its answers, in case it has been overridden for site policy
833(defmethod perform ((operation compile-op) (c cl-source-file))
834  #-:broken-fasl-loader
835  (let ((source-file (component-pathname c))
836        (output-file (car (output-files operation c))))
837    (multiple-value-bind (output warnings-p failure-p)
838        (compile-file source-file :output-file output-file)
839      (when warnings-p
840        (case (operation-on-warnings operation)
841          (:warn (warn
842                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
843                  operation c))
844          (:error (error 'compile-warned :component c :operation operation))
845          (:ignore nil)))
846      (when failure-p
847        (case (operation-on-failure operation)
848          (:warn (warn
849                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
850                  operation c))
851          (:error (error 'compile-failed :component c :operation operation))
852          (:ignore nil)))
853      (unless output
854        (error 'compile-error :component c :operation operation)))))
855
856(defmethod output-files ((operation compile-op) (c cl-source-file))
857  #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
858  #+:broken-fasl-loader (list (component-pathname c)))
859
860(defmethod perform ((operation compile-op) (c static-file))
861  nil)
862
863(defmethod output-files ((operation compile-op) (c static-file))
864  nil)
865
866(defmethod input-files ((op compile-op) (c static-file))
867  nil)
868
869
870;;; load-op
871
872(defclass basic-load-op (operation) ())
873
874(defclass load-op (basic-load-op) ())
875
876(defmethod perform ((o load-op) (c cl-source-file))
877  (mapcar #'load (input-files o c)))
878
879(defmethod perform around ((o load-op) (c cl-source-file))
880  (let ((state :initial))
881    (loop until (or (eq state :success)
882                    (eq state :failure)) do
883         (case state
884           (:recompiled
885            (setf state :failure)
886            (call-next-method)
887            (setf state :success))
888           (:failed-load
889            (setf state :recompiled)
890            (perform (make-instance 'asdf:compile-op) c))
891           (t
892            (with-simple-restart 
893                (try-recompiling "Recompile ~a and try loading it again"
894                                  (component-name c))
895              (setf state :failed-load)
896              (call-next-method)
897              (setf state :success)))))))
898
899(defmethod perform around ((o compile-op) (c cl-source-file))
900  (let ((state :initial))
901    (loop until (or (eq state :success)
902                    (eq state :failure)) do
903         (case state
904           (:recompiled
905            (setf state :failure)
906            (call-next-method)
907            (setf state :success))
908           (:failed-compile
909            (setf state :recompiled)
910            (perform (make-instance 'asdf:compile-op) c))
911           (t
912            (with-simple-restart 
913                (try-recompiling "Try recompiling ~a"
914                                  (component-name c))
915              (setf state :failed-compile)
916              (call-next-method)
917              (setf state :success)))))))
918
919(defmethod perform ((operation load-op) (c static-file))
920  nil)
921
922(defmethod operation-done-p ((operation load-op) (c static-file))
923  t)
924
925(defmethod output-files ((o operation) (c component))
926  nil)
927
928(defmethod component-depends-on ((operation load-op) (c component))
929  (cons (list 'compile-op (component-name c))
930        (call-next-method)))
931
932;;; load-source-op
933
934(defclass load-source-op (basic-load-op) ())
935
936(defmethod perform ((o load-source-op) (c cl-source-file))
937  (let ((source (component-pathname c)))
938    (setf (component-property c 'last-loaded-as-source)
939          (and (load source)
940               (get-universal-time)))))
941
942(defmethod perform ((operation load-source-op) (c static-file))
943  nil)
944
945(defmethod output-files ((operation load-source-op) (c component))
946  nil)
947
948;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
949(defmethod component-depends-on ((o load-source-op) (c component))
950  (let ((what-would-load-op-do (cdr (assoc 'load-op
951                                           (slot-value c 'in-order-to)))))
952    (mapcar (lambda (dep)
953              (if (eq (car dep) 'load-op)
954                  (cons 'load-source-op (cdr dep))
955                  dep))
956            what-would-load-op-do)))
957
958(defmethod operation-done-p ((o load-source-op) (c source-file))
959  (if (or (not (component-property c 'last-loaded-as-source))
960          (> (file-write-date (component-pathname c))
961             (component-property c 'last-loaded-as-source)))
962      nil t))
963
964(defclass test-op (operation) ())
965
966(defmethod perform ((operation test-op) (c component))
967  nil)
968
969(defmethod operation-done-p ((operation test-op) (c system))
970  "Testing a system is _never_ done."
971  nil)
972
973;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
974;;; invoking operations
975
976(defvar *operate-docstring*
977  "Operate does three things:
978
9791. It creates an instance of `operation-class` using any keyword parameters
980as initargs.
9812. It finds the  asdf-system specified by `system` (possibly loading
982it from disk).
9833. It then calls `traverse` with the operation and system as arguments
984
985The traverse operation is wrapped in `with-compilation-unit` and error
986handling code. If a `version` argument is supplied, then operate also
987ensures that the system found satisfies it using the `version-satisfies`
988method.")
989
990(defun operate (operation-class system &rest args &key (verbose t) version
991                &allow-other-keys)
992  (let* ((op (apply #'make-instance operation-class
993                    :original-initargs args
994                    args))
995         (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
996         (system (if (typep system 'component) system (find-system system))))
997    (unless (version-satisfies system version)
998      (error 'missing-component-of-version :requires system :version version))
999    (let ((steps (traverse op system)))
1000      (with-compilation-unit ()
1001        (loop for (op . component) in steps do
1002                 (loop
1003                   (restart-case
1004                       (progn (perform op component)
1005                              (return))
1006                     (retry ()
1007                       :report
1008                       (lambda (s)
1009                         (format s "~@<Retry performing ~S on ~S.~@:>"
1010                                 op component)))
1011                     (accept ()
1012                       :report
1013                       (lambda (s)
1014                         (format s "~@<Continue, treating ~S on ~S as ~
1015                                   having been successful.~@:>"
1016                                 op component))
1017                       (setf (gethash (type-of op)
1018                                      (component-operation-times component))
1019                             (get-universal-time))
1020                       (return)))))))))
1021
1022(setf (documentation 'operate 'function)
1023      *operate-docstring*)
1024
1025(defun oos (operation-class system &rest args &key force (verbose t) version)
1026  (declare (ignore force verbose version))
1027  (apply #'operate operation-class system args))
1028
1029(setf (documentation 'oos 'function)
1030      (format nil
1031              "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
1032              *operate-docstring*))
1033
1034;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1035;;; syntax
1036
1037(defun remove-keyword (key arglist)
1038  (labels ((aux (key arglist)
1039             (cond ((null arglist) nil)
1040                   ((eq key (car arglist)) (cddr arglist))
1041                   (t (cons (car arglist) (cons (cadr arglist)
1042                                                (remove-keyword
1043                                                 key (cddr arglist))))))))
1044    (aux key arglist)))
1045
1046(defmacro defsystem (name &body options)
1047  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
1048                            &allow-other-keys)
1049      options
1050    (let ((component-options (remove-keyword :class options)))
1051      `(progn
1052         ;; system must be registered before we parse the body, otherwise
1053         ;; we recur when trying to find an existing system of the same name
1054         ;; to reuse options (e.g. pathname) from
1055         (let ((s (system-registered-p ',name)))
1056           (cond ((and s (eq (type-of (cdr s)) ',class))
1057                  (setf (car s) (get-universal-time)))
1058                 (s
1059                  #+clisp
1060                  (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
1061                  #-clisp
1062                  (change-class (cdr s) ',class))
1063                 (t
1064                  (register-system (quote ,name)
1065                                   (make-instance ',class :name ',name)))))
1066         (parse-component-form nil (apply
1067                                    #'list
1068                                    :module (coerce-name ',name)
1069                                    :pathname
1070                                    ;; to avoid a note about unreachable code
1071                                    ,(if pathname-arg-p
1072                                         pathname
1073                                         `(or (when *load-truename*
1074                                                (pathname-sans-name+type
1075                                                 (resolve-symlinks
1076                                                  *load-truename*)))
1077                                              *default-pathname-defaults*))
1078                                    ',component-options))))))
1079
1080
1081(defun class-for-type (parent type)
1082  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
1083                              (find-symbol (symbol-name type)
1084                                           (load-time-value
1085                                            (package-name :asdf)))))
1086         (class (dolist (symbol (if (keywordp type)
1087                                    extra-symbols
1088                                    (cons type extra-symbols)))
1089                  (when (and symbol
1090                             (find-class symbol nil)
1091                             (subtypep symbol 'component))
1092                    (return (find-class symbol))))))
1093    (or class
1094        (and (eq type :file)
1095             (or (module-default-component-class parent)
1096                 (find-class 'cl-source-file)))
1097        (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
1098
1099(defun maybe-add-tree (tree op1 op2 c)
1100  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
1101Returns the new tree (which probably shares structure with the old one)"
1102  (let ((first-op-tree (assoc op1 tree)))
1103    (if first-op-tree
1104        (progn
1105          (aif (assoc op2 (cdr first-op-tree))
1106               (if (find c (cdr it))
1107                   nil
1108                   (setf (cdr it) (cons c (cdr it))))
1109               (setf (cdr first-op-tree)
1110                     (acons op2 (list c) (cdr first-op-tree))))
1111          tree)
1112        (acons op1 (list (list op2 c)) tree))))
1113
1114(defun union-of-dependencies (&rest deps)
1115  (let ((new-tree nil))
1116    (dolist (dep deps)
1117      (dolist (op-tree dep)
1118        (dolist (op  (cdr op-tree))
1119          (dolist (c (cdr op))
1120            (setf new-tree
1121                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
1122    new-tree))
1123
1124
1125(defun remove-keys (key-names args)
1126  (loop for ( name val ) on args by #'cddr
1127        unless (member (symbol-name name) key-names
1128                       :key #'symbol-name :test 'equal)
1129        append (list name val)))
1130
1131(defvar *serial-depends-on*)
1132
1133(defun parse-component-form (parent options)
1134
1135  (destructuring-bind
1136        (type name &rest rest &key
1137              ;; the following list of keywords is reproduced below in the
1138              ;; remove-keys form.  important to keep them in sync
1139              components pathname default-component-class
1140              perform explain output-files operation-done-p
1141              weakly-depends-on
1142              depends-on serial in-order-to
1143              ;; list ends
1144              &allow-other-keys) options
1145    (declare (ignorable perform explain output-files operation-done-p))
1146    (check-component-input type name weakly-depends-on depends-on components in-order-to)
1147
1148    (when (and parent
1149               (find-component parent name)
1150               ;; ignore the same object when rereading the defsystem
1151               (not
1152                (typep (find-component parent name)
1153                       (class-for-type parent type))))
1154      (error 'duplicate-names :name name))
1155
1156    (let* ((other-args (remove-keys
1157                        '(components pathname default-component-class
1158                          perform explain output-files operation-done-p
1159                          weakly-depends-on
1160                          depends-on serial in-order-to)
1161                        rest))
1162           (ret
1163            (or (find-component parent name)
1164                (make-instance (class-for-type parent type)))))
1165      (when weakly-depends-on
1166        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
1167      (when (boundp '*serial-depends-on*)
1168        (setf depends-on
1169              (concatenate 'list *serial-depends-on* depends-on)))
1170      (apply #'reinitialize-instance ret
1171             :name (coerce-name name)
1172             :pathname pathname
1173             :parent parent
1174             other-args)
1175      (when (typep ret 'module)
1176        (setf (module-default-component-class ret)
1177              (or default-component-class
1178                  (and (typep parent 'module)
1179                       (module-default-component-class parent))))
1180        (let ((*serial-depends-on* nil))
1181          (setf (module-components ret)
1182                (loop for c-form in components
1183                      for c = (parse-component-form ret c-form)
1184                      collect c
1185                      if serial
1186                      do (push (component-name c) *serial-depends-on*))))
1187
1188        ;; check for duplicate names
1189        (let ((name-hash (make-hash-table :test #'equal)))
1190          (loop for c in (module-components ret)
1191                do
1192                (if (gethash (component-name c)
1193                             name-hash)
1194                    (error 'duplicate-names
1195                           :name (component-name c))
1196                    (setf (gethash (component-name c)
1197                                   name-hash)
1198                          t)))))
1199
1200      (setf (slot-value ret 'in-order-to)
1201            (union-of-dependencies
1202             in-order-to
1203             `((compile-op (compile-op ,@depends-on))
1204               (load-op (load-op ,@depends-on))))
1205            (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
1206
1207      (%remove-component-inline-methods ret rest)
1208
1209      ret)))
1210
1211(defun %remove-component-inline-methods (ret rest)
1212  (loop for name in +asdf-methods+
1213        do (map 'nil
1214                ;; this is inefficient as most of the stored
1215                ;; methods will not be for this particular gf n
1216                ;; But this is hardly performance-critical
1217                (lambda (m)
1218                  (remove-method (symbol-function name) m))
1219                (component-inline-methods ret)))
1220  ;; clear methods, then add the new ones
1221  (setf (component-inline-methods ret) nil)
1222  (loop for name in +asdf-methods+
1223        for v = (getf rest (intern (symbol-name name) :keyword))
1224        when v do
1225        (destructuring-bind (op qual (o c) &body body) v
1226          (pushnew
1227           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
1228                             ,@body))
1229           (component-inline-methods ret)))))
1230
1231(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
1232  "A partial test of the values of a component."
1233  (when weakly-depends-on (warn "We got one! XXXXX"))
1234  (unless (listp depends-on)
1235    (sysdef-error-component ":depends-on must be a list."
1236                            type name depends-on))
1237  (unless (listp weakly-depends-on)
1238    (sysdef-error-component ":weakly-depends-on must be a list."
1239                            type name weakly-depends-on))
1240  (unless (listp components)
1241    (sysdef-error-component ":components must be NIL or a list of components."
1242                            type name components))
1243  (unless (and (listp in-order-to) (listp (car in-order-to)))
1244    (sysdef-error-component ":in-order-to must be NIL or a list of components."
1245                            type name in-order-to)))
1246
1247(defun sysdef-error-component (msg type name value)
1248  (sysdef-error (concatenate 'string msg
1249                             "~&The value specified for ~(~A~) ~A is ~W")
1250                type name value))
1251
1252(defun resolve-symlinks (path)
1253  #-allegro (truename path)
1254  #+allegro (excl:pathname-resolve-symbolic-links path)
1255  )
1256
1257;;; optional extras
1258
1259;;; run-shell-command functions for other lisp implementations will be
1260;;; gratefully accepted, if they do the same thing.  If the docstring
1261;;; is ambiguous, send a bug report
1262
1263(defun run-shell-command (control-string &rest args)
1264  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
1265synchronously execute the result using a Bourne-compatible shell, with
1266output to *VERBOSE-OUT*.  Returns the shell's exit code."
1267  (let ((command (apply #'format nil control-string args)))
1268    (format *verbose-out* "; $ ~A~%" command)
1269    #+sbcl
1270    (sb-ext:process-exit-code
1271     (sb-ext:run-program
1272      #+win32 "sh" #-win32 "/bin/sh"
1273      (list  "-c" command)
1274      #+win32 #+win32 :search t
1275      :input nil :output *verbose-out*))
1276
1277    #+(or cmu scl)
1278    (ext:process-exit-code
1279     (ext:run-program
1280      "/bin/sh"
1281      (list  "-c" command)
1282      :input nil :output *verbose-out*))
1283
1284    #+allegro
1285    (excl:run-shell-command command :input nil :output *verbose-out*)
1286
1287    #+lispworks
1288    (system:call-system-showing-output
1289     command
1290     :shell-type "/bin/sh"
1291     :output-stream *verbose-out*)
1292
1293    #+clisp                     ;XXX not exactly *verbose-out*, I know
1294    (ext:run-shell-command  command :output :terminal :wait t)
1295
1296    #+openmcl
1297    (nth-value 1
1298               (ccl:external-process-status
1299                (ccl:run-program "/bin/sh" (list "-c" command)
1300                                 :input nil :output *verbose-out*
1301                                 :wait t)))
1302    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
1303    (si:system command)
1304    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
1305    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
1306    ))
1307
1308(defgeneric system-source-file (system)
1309  (:documentation "Return the source file in which system is defined."))
1310
1311(defmethod system-source-file ((system-name t))
1312  (system-source-file (find-system system-name)))
1313
1314(defmethod system-source-file ((system system))
1315  (let ((pn (and (slot-boundp system 'relative-pathname)
1316                 (make-pathname
1317                  :type "asd"
1318                  :name (asdf:component-name system)
1319                  :defaults (asdf:component-relative-pathname system)))))
1320    (when pn
1321      (probe-file pn))))
1322 
1323(defun system-source-directory (system-name)
1324  (make-pathname :name nil
1325                 :type nil
1326                 :defaults (system-source-file system-name)))
1327
1328(defun system-relative-pathname (system pathname &key name type)
1329  ;; you're not allowed to muck with the return value of pathname-X
1330  (let ((directory (copy-list (pathname-directory pathname))))
1331    (when (eq (car directory) :absolute)
1332      (setf (car directory) :relative))
1333    (merge-pathnames
1334     (make-pathname :name (or name (pathname-name pathname))
1335                    :type (or type (pathname-type pathname))
1336                    :directory directory)
1337     (system-source-directory system))))
1338
1339(pushnew :asdf *features*)
1340
1341#+sbcl
1342(eval-when (:compile-toplevel :load-toplevel :execute)
1343  (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
1344    (pushnew :sbcl-hooks-require *features*)))
1345
1346#+(and sbcl sbcl-hooks-require)
1347(progn
1348  (defun module-provide-asdf (name)
1349    (handler-bind ((style-warning #'muffle-warning))
1350      (let* ((*verbose-out* (make-broadcast-stream))
1351             (system (asdf:find-system name nil)))
1352        (when system
1353          (asdf:operate 'asdf:load-op name)
1354          t))))
1355
1356  (defun contrib-sysdef-search (system)
1357    (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
1358      (when (and home (not (string= home "")))
1359        (let* ((name (coerce-name system))
1360               (home (truename home))
1361               (contrib (merge-pathnames
1362                         (make-pathname :directory `(:relative ,name)
1363                                        :name name
1364                                        :type "asd"
1365                                        :case :local
1366                                        :version :newest)
1367                         home)))
1368          (probe-file contrib)))))
1369
1370  (pushnew
1371   '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
1372      (when (and home (not (string= home "")))
1373        (merge-pathnames "site-systems/" (truename home))))
1374   *central-registry*)
1375
1376  (pushnew
1377   '(merge-pathnames ".sbcl/systems/"
1378     (user-homedir-pathname))
1379   *central-registry*)
1380
1381  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
1382  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
1383
1384(provide 'asdf)
Note: See TracBrowser for help on using the repository browser.