← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to contrib/asdf/asdf-ecl.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/asdf/asdf-ecl.lisp
 
1
;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
 
2
;;;
 
3
;;;   This program is free software; you can redistribute it and/or
 
4
;;;   modify it under the terms of the GNU Library General Public
 
5
;;;   License as published by the Free Software Foundation; either
 
6
;;;   version 2 of the License, or (at your option) any later version.
 
7
;;;
 
8
;;;   See file '../../Copyright' for full details.
 
9
;;;
 
10
;;; ECL SPECIFIC OPERATIONS FOR ASDF
 
11
;;;
 
12
 
 
13
(in-package :asdf)
 
14
 
 
15
(defclass load-record-op (operation) ())
 
16
 
 
17
(defmethod operation-done-p ((o load-record-op) (c component))
 
18
  nil)
 
19
 
 
20
(defmethod component-depends-on ((o load-record-op) (c component))
 
21
  (let ((deps (component-original-depends-on c))
 
22
        (c-deps (call-next-method)))
 
23
    (when (and deps (not (typep c 'system)))
 
24
      (push `(load-record-op ,@deps) c-deps))
 
25
    c-deps))
 
26
 
 
27
(defun load-file-list (component)
 
28
  (let* ((op (make-instance 'load-record-op))
 
29
         (steps (traverse op component)))
 
30
    (loop for (o . c) in steps
 
31
          when (typep c 'cl-source-file)
 
32
          collect c)))
 
33
 
 
34
(defclass build-op (compile-op)
 
35
  ((type :initarg :type :initform :fasl :accessor build-op-type)
 
36
   (monolithic :initarg :monolithic :initform t :accessor build-op-monolithic)
 
37
   (args :initarg :args :initform nil :accessor build-op-args)))
 
38
 
 
39
(defmethod initialize-instance :after ((instance build-op) &rest initargs &key &allow-other-keys)
 
40
  (setf (slot-value instance 'system-p) t)
 
41
  (let ((args (remove-keys '(type) (slot-value instance 'original-initargs)))
 
42
        (sub-type (build-op-type instance)))
 
43
    (case sub-type
 
44
      ((:fasl :dll :shared-library) (when (build-op-monolithic instance) (setf sub-type :lib)))
 
45
      (:program (setf sub-type :lib))
 
46
      (t))
 
47
    (setf (slot-value instance 'original-initargs)
 
48
          (append `(:type ,sub-type)
 
49
                  args))))
 
50
 
 
51
(defmethod component-depends-on ((o build-op) (c component))
 
52
  (let ((deps (component-original-depends-on c))
 
53
        (c-deps (call-next-method)))
 
54
    (when deps
 
55
      (push `(build-op ,@deps) c-deps))
 
56
    c-deps))
 
57
 
 
58
(defmethod output-files ((o build-op) (c cl-source-file))
 
59
  (list (compile-file-pathname (component-pathname c) :type :object)))
 
60
 
 
61
(defun get-object-files (component)
 
62
  (loop for c in (load-file-list component)
 
63
        collect (car (output-files (make-instance 'build-op) c))))
 
64
 
 
65
(defmethod output-files ((o build-op) (c system))
 
66
  (list (merge-pathnames (component-pathname c)
 
67
                         (compile-file-pathname (component-name c) :type (build-op-type o)))))
 
68
 
 
69
(defmethod input-files ((o build-op) (c system))
 
70
  (append (get-object-files c)
 
71
          (and (component-original-depends-on c)
 
72
               (build-op-monolithic o)
 
73
               (loop for d in (component-original-depends-on c)
 
74
                     collect (car (output-files (make-instance 'build-op :type :lib) (find-system d)))))))
 
75
 
 
76
(defmethod perform ((o build-op) (c system))
 
77
  (let ((obj-files (get-object-files c))
 
78
        (out-file (car (output-files o c)))
 
79
        (deps (component-original-depends-on c)))
 
80
    (when (and deps (build-op-monolithic o))
 
81
      (setq obj-files
 
82
            (append (loop for d in deps
 
83
                          collect (if (symbolp d) d (make-symbol d)))
 
84
                    obj-files)))
 
85
    (apply #'c::builder (build-op-type o) out-file :lisp-files obj-files (build-op-args o))))
 
86
 
 
87
(defmethod traverse ((o build-op) (c system))
 
88
  (let* ((load-tree (traverse (make-instance 'load-source-op :parent o) c))
 
89
         (tree (call-next-method)))
 
90
    (append load-tree tree)))
 
91
 
 
92
(defun make-build (&rest args)
 
93
  (apply #'operate 'build-op args))
 
94
 
 
95
(dolist (sym '(build-op make-build))
 
96
  (export sym))