/[meta-cvs]/meta-cvs/F-F8FB346C85583F5BA0474148BA2A0E28.lisp
ViewVC logotype

Diff of /meta-cvs/F-F8FB346C85583F5BA0474148BA2A0E28.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5