source: trunk/ccl/tools/asdf.lisp @ 4703

Last change on this file since 4703 was 4703, checked in by gwking, 13 years ago

Updated asdf to the current CVS head (revision 1.98)

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