Newer
Older
(if (and m (version-satisfies m version)) m)))
(defclass source-file (component) ())
(defclass cl-source-file (source-file) ())
(defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ())
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
(defmethod source-file-type ((c c-source-file) (s module)) "c")
(defmethod source-file-type ((c java-source-file) (s module)) "java")
(defmethod source-file-type ((c static-file) (s module)) nil)
(defun merge-component-relative-pathname (pathname name type)
(multiple-value-bind (relative path filename)
(split-path-string name)
(merge-pathnames
(or pathname (make-pathname :directory `(,relative ,@path)))
(if type
(make-pathname :name filename :type type)
filename))))
(defmethod component-relative-pathname ((component source-file))
Francois-Rene Rideau
committed
;; This binding of *default-pathname-defaults* is required notably because
;; it will provide the default host to the above make-pathname, which may
;; crucially matter to e.g. people somehow using logical-pathnames.
(let ((*default-pathname-defaults*
(component-pathname (component-parent component))))
(merge-component-relative-pathname
(slot-value component 'relative-pathname)
(component-name component)
(source-file-type component (component-system component)))))
;;;; -------------------------------------------------------------------------
;;;; Operations
;;; one of these is instantiated whenever #'operate is called
(
;; what is the TYPE of this slot? seems like it should be boolean,
;; but TRAVERSE checks to see if it's a list of component names...
;; [2010/02/07:rpg]
(forced :initform nil :initarg :force :accessor operation-forced)
(original-initargs :initform nil :initarg :original-initargs
(visited-nodes :initform nil :accessor operation-visited-nodes)
(visiting-nodes :initform nil :accessor operation-visiting-nodes)
(parent :initform nil :initarg :parent :accessor operation-parent)))
(defmethod print-object ((o operation) stream)
(print-unreadable-object (o stream :type t :identity t)
(ignore-errors
(prin1 (operation-original-initargs o) stream))))
(defmethod shared-initialize :after ((operation operation) slot-names
(declare (ignorable operation slot-names force))
;; empty method to disable initarg validity checking
)
(defun node-for (o c)
(cons (class-name (class-of o)) c))
(defmethod operation-ancestor ((operation operation))
(aif (operation-parent operation)
(operation-ancestor it)
operation))
(defun make-sub-operation (c o dep-c dep-o)
"C is a component, O is an operation, DEP-C is another
component, and DEP-O, confusingly enough, is an operation
class specifier, not an operation."
(let* ((args (copy-list (operation-original-initargs o)))
;; note explicit comparison with T: any other non-NIL force value
;; (e.g. :recursive) will pass through
(cond ((and (null (component-parent c))
(null (component-parent dep-c))
(not (eql c dep-c)))
(when (eql force-p t)
(setf (getf args :force) nil))
(apply #'make-instance dep-o
:parent o
:original-initargs args args))
((subtypep (type-of o) dep-o)
o)
(t
(apply #'make-instance dep-o
:parent o :original-initargs args args)))))
(defmethod visit-component ((o operation) (c component) data)
(unless (component-visited-p o c)
(push (cons (node-for o c) data)
(operation-visited-nodes (operation-ancestor o)))))
(defmethod component-visited-p ((o operation) (c component))
(operation-visited-nodes (operation-ancestor o))
:test 'equal))
(defmethod (setf visiting-component) (new-value operation component)
;; MCL complains about unused lexical variables
(declare (ignorable new-value operation component)))
(defmethod (setf visiting-component) (new-value (o operation) (c component))
(let ((node (node-for o c))
(if new-value
(pushnew node (operation-visiting-nodes a) :test 'equal)
(setf (operation-visiting-nodes a)
(remove node (operation-visiting-nodes a) :test 'equal)))))
(defmethod component-visiting-p ((o operation) (c component))
(let ((node (node-for o c)))
(member node (operation-visiting-nodes (operation-ancestor o))
(defmethod component-depends-on ((op-spec symbol) (c component))
(component-depends-on (make-instance op-spec) c))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (class-name (class-of o))
Francois-Rene Rideau
committed
(component-in-order-to c))))
(defmethod component-self-dependencies ((o operation) (c component))
(let ((all-deps (component-depends-on o c)))
(remove-if-not (lambda (x)
(member (component-name c) (cdr x) :test #'string=))
all-deps)))
(defmethod input-files ((operation operation) (c component))
(let ((parent (component-parent c))
(self-deps (component-self-dependencies operation c)))
(mapcan (lambda (dep)
(destructuring-bind (op name) dep
(output-files (make-instance op)
(find-component parent name))))
self-deps)
;; no previous operations needed? I guess we work with the
;; original source file, then
(list (component-pathname c)))))
(defmethod input-files ((operation operation) (c module)) nil)

Daniel Barlow
committed
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
(in-files (input-files o c))
(op-time (gethash (type-of o) (component-operation-times c))))
(flet ((earliest-out ()
(reduce #'min (mapcar #'safe-file-write-date out-files)))
(latest-in ()
(reduce #'max (mapcar #'safe-file-write-date in-files))))
(cond
((and (not in-files) (not out-files))
;; arbitrary decision: an operation that uses nothing to
;; produce nothing probably isn't doing much.
;; e.g. operations on systems, modules that have no immediate action,
;; but are only meaningful through traversed dependencies
t)
((not out-files)
;; an operation without output-files is probably meant
;; for its side-effects in the current image,
;; assumed to be idem-potent,
;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
(and op-time
(>= op-time (latest-in))))
((not in-files)
;; an operation without output-files and no input-files
;; is probably meant for its side-effects on the file-system,
;; assumed to have to be done everytime.
;; (I don't think there is any such case in ASDF unless extended)
nil)
(t
;; an operation with both input and output files is assumed
;; as computing the latter from the former,
;; assumed to have been done if the latter are all older
;; than the former.
;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
(and
(every #'probe-file in-files)
(every #'probe-file out-files)
(and (> (earliest-out) (latest-in)))))))))
;;; So you look at this code and think "why isn't it a bunch of
;;; methods". And the answer is, because standard method combination
;;; runs :before methods most->least-specific, which is back to front
(defvar *forcing* nil
"This dynamically-bound variable is used to force operations in
recursive calls to traverse.")
(defmethod traverse ((operation operation) (c component))
(let ((forced nil)) ;return value -- everyone side-effects onto this
(labels ((%do-one-dep (required-op required-c required-v)
;; returns a partial plan that results from performing required-op
;; on required-c, possibly with a required-vERSION
(let* ((dep-c (or (find-component
(component-parent c)
;; XXX tacky. really we should build the
;; in-order-to slot with canonicalized
;; names instead of coercing this late
(coerce-name required-c) required-v)
(if required-v
(error 'missing-dependency-of-version
:required-by c
:version required-v
:requires required-c)
(error 'missing-dependency
:required-by c
:requires required-c))))
(op (make-sub-operation c operation dep-c required-op)))
(traverse op dep-c)))
;; this function is a thin, error-handling wrapper around
;; %do-one-dep. Returns a partial plan per that function.
(restart-case
(return (%do-one-dep required-op required-c required-v))
(retry ()
:report (lambda (s)
(format s "~@<Retry loading component ~S.~@:>"
required-c))
:test
(lambda (c)
(print (list :c1 c (typep c 'missing-dependency)))
(when (typep c 'missing-dependency)
(print (list :c2 (missing-requires c) required-c
(equalp (missing-requires c)
required-c))))
(or (null c)
(and (typep c 'missing-dependency)
(equalp (missing-requires c)
required-c))))))))
;; type of arguments uncertain: op seems to at least potentially be a
;; symbol, rather than an operation
;; dep is either a list of component names (?) or (we hope) a single
;; component name.
;; handle a single dependency, returns nothing of interest --- side-
;; effects onto the FORCED variable, which is scoped over TRAVERSE
(cond ((eq op 'feature)
(or (member (car dep) *features*)
:requires (car dep))))
;; structured dependencies --- this parses keywords
;; the keywords could be broken out and cleanly (extensibly)
;; processed by EQL methods, but for the pervasive side-effecting
;; onto FORCED
(cond ((string-equal
(symbol-name (first d))
"VERSION")
(appendf
forced
(do-one-dep op (second d) (third d))))
;; this particular subform is not documented, indeed
;; clashes with the documentation, since it assumes a
;; third component
((and (string-equal
(symbol-name (first d))
"FEATURE")
(find (second d) *features*
:test 'string-equal))
(appendf
forced
(do-one-dep op (second d) (third d))))
(t
(error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
(t
(appendf forced (do-one-dep op d nil)))))))))
(aif (component-visited-p operation c)
(return-from traverse
(if (cdr it) (list (cons 'pruned-op c)) nil)))
(error 'circular-dependency :components (list c)))
;; first we check and do all the dependencies for the
;; module. Operations planned in this loop will show up
;; in the contents of the FORCED variable, and are consumed
;; downstream (watch out for the shadowing FORCED variable
;; around the DOLIST below!)
(let ((*forcing* nil))
;; upstream dependencies are never forced to happen just because
;; the things that depend on them are....
(loop :for (required-op . deps) :in
(component-depends-on operation c)
:do (do-dep required-op deps)))
;; constituent bits
(let ((module-ops
(when (typep c 'module)
(let ((at-least-one nil)
(forced nil)
;; this is set based on the results of the
;; dependencies and whether we are in the
;; context of a *forcing* call...
(must-operate (or *forcing*
;; inter-system dependencies do NOT trigger
;; building components
(and
(not (typep c 'system))
forced)))
(error nil))
(dolist (kid (module-components c))
(handler-case
(let ((*forcing* must-operate))
(appendf forced (traverse operation kid)))
(missing-dependency (condition)
(when (eq (module-if-component-dep-fails c)
:fail)
(error condition))
(setf error condition))
(:no-error (c)
(declare (ignore c))
(setf at-least-one t))))
(when (and (eq (module-if-component-dep-fails c)
:try-next)
(not at-least-one))
(error error))
forced))))
;; now the thing itself
;; the test here is a bit oddly written. FORCED here doesn't
;; mean that this operation is forced on this component, but that
;; something upstream of this component has been forced.
(when (or forced module-ops
(not (operation-done-p operation c))
(let ((f (operation-forced
(operation-ancestor operation))))
;; does anyone fully understand the following condition?
;; if so, please add a comment to explain it...
(and f (or (not (consp f))
(member (component-name
(operation-ancestor operation))
(mapcar #'coerce-name f)
;; this was string=, but for the benefit
;; of mlisp, we use string-equal for this
;; purpose.
:test #'string-equal)))))
(let ((do-first (cdr (assoc (class-name (class-of operation))
(component-do-first c)))))
(loop :for (required-op . deps) :in do-first
:do (do-dep required-op deps)))
(setf forced (append (delete 'pruned-op forced :key #'car)
(delete 'pruned-op module-ops :key #'car)
(list (cons operation c)))))))
(defmethod perform ((operation operation) (c source-file))
Christophe Rhodes
committed
"~@<required method PERFORM not implemented ~
for operation ~A, component ~A~@:>"
(class-of operation) (class-of c)))
(defmethod perform ((operation operation) (c module))
nil)
(defmethod explain ((operation operation) (component component))
(asdf-message "~&;;; ~A on ~A~%" operation component))
;;;; -------------------------------------------------------------------------
;;;; compile-op
(defclass compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
:initform *compile-file-warnings-behaviour*)
:initform *compile-file-failure-behaviour*)
Francois-Rene Rideau
committed
(flags :initarg :flags :accessor compile-op-flags
:initform #-ecl nil #+ecl '(:system-p t))))
(defmethod perform :before ((operation compile-op) (c source-file))
(map nil #'ensure-directories-exist (output-files operation c)))
Francois-Rene Rideau
committed
#+ecl
(defmethod perform :after ((o compile-op) (c cl-source-file))
;; Note how we use OUTPUT-FILES to find the binary locations
;; This allows the user to override the names.
(let* ((input (output-files o c))
(output (compile-file-pathname (first input) :type :fasl)))
(c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
(defmethod perform :after ((operation operation) (c component))
(setf (gethash (type-of operation) (component-operation-times c))
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(defmethod perform ((operation compile-op) (c cl-source-file))

Daniel Barlow
committed
(let ((source-file (component-pathname c))
(output-file (car (output-files operation c))))
(apply #'compile-file source-file :output-file output-file
(compile-op-flags operation))
(case (operation-on-warnings operation)
(:warn (warn
"~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
operation c))
(:error (error 'compile-warned :component c :operation operation))
(:ignore nil)))
(case (operation-on-failure operation)
(:warn (warn
"~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
operation c))
(:error (error 'compile-failed :component c :operation operation))
(:ignore nil)))
(unless output
(error 'compile-error :component c :operation operation)))))
(defmethod output-files ((operation compile-op) (c cl-source-file))
Francois-Rene Rideau
committed
#-:broken-fasl-loader
(list #-ecl (compile-file-pathname (component-pathname c))
#+ecl (compile-file-pathname (component-pathname c) :type :object)
#+ecl (compile-file-pathname (component-pathname c) :type :fasl))
#+:broken-fasl-loader (list (component-pathname c)))
(defmethod perform ((operation compile-op) (c static-file))
nil)
(defmethod output-files ((operation compile-op) (c static-file))
nil)
(defmethod input-files ((op compile-op) (c static-file))
nil)
;;;; -------------------------------------------------------------------------
;;;; load-op
(defclass basic-load-op (operation) ())
(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
Francois-Rene Rideau
committed
#-ecl (mapcar #'load (input-files o c))
#+ecl (loop :for i :in (input-files o c)
:unless (string= (pathname-type i) "fas")
:collect (let ((output (compile-file-pathname i)))
(load output))))
(defmethod perform around ((o load-op) (c cl-source-file))
Gary King
committed
(let ((state :initial))
(loop :until (or (eq state :success)
(eq state :failure)) :do
(case state
(:recompiled
(setf state :failure)
(call-next-method)
(setf state :success))
(:failed-load
(setf state :recompiled)
(perform (make-instance 'asdf:compile-op) c))
(t
(with-simple-restart
(try-recompiling "Recompile ~a and try loading it again"
(component-name c))
(setf state :failed-load)
(call-next-method)
(setf state :success)))))))
Gary King
committed
(defmethod perform around ((o compile-op) (c cl-source-file))
Gary King
committed
(let ((state :initial))
(loop :until (or (eq state :success)
(eq state :failure)) :do
(case state
(:recompiled
(setf state :failure)
(call-next-method)
(setf state :success))
(:failed-compile
(setf state :recompiled)
(perform (make-instance 'asdf:compile-op) c))
(t
(with-simple-restart
(try-recompiling "Try recompiling ~a"
(component-name c))
(setf state :failed-compile)
(call-next-method)
(setf state :success)))))))
Gary King
committed
(defmethod perform ((operation load-op) (c static-file))
nil)
Gary King
committed
(defmethod operation-done-p ((operation load-op) (c static-file))
t)
(defmethod component-depends-on ((operation load-op) (c component))
(cons (list 'compile-op (component-name c))
(call-next-method)))
;;;; -------------------------------------------------------------------------
;;;; load-source-op
(defclass load-source-op (basic-load-op) ())
(defmethod perform ((o load-source-op) (c cl-source-file))

Kevin Rosenberg
committed
(let ((source (component-pathname c)))
(setf (component-property c 'last-loaded-as-source)
(and (load source)
(get-universal-time)))))
(defmethod perform ((operation load-source-op) (c static-file))
nil)
(defmethod output-files ((operation load-source-op) (c component))
nil)
;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))
(let ((what-would-load-op-do (cdr (assoc 'load-op
Francois-Rene Rideau
committed
(component-in-order-to c)))))

Kevin Rosenberg
committed
(mapcar (lambda (dep)
(if (eq (car dep) 'load-op)
(cons 'load-source-op (cdr dep))
dep))
what-would-load-op-do)))
(defmethod operation-done-p ((o load-source-op) (c source-file))
(if (or (not (component-property c 'last-loaded-as-source))
(> (safe-file-write-date (component-pathname c))
(component-property c 'last-loaded-as-source)))

Kevin Rosenberg
committed
nil t))
;;;; -------------------------------------------------------------------------
;;;; test-op
(defclass test-op (operation) ())
(defmethod perform ((operation test-op) (c component))
nil)
(defmethod operation-done-p ((operation test-op) (c system))
"Testing a system is _never_ done."
nil)
(defmethod component-depends-on :around ((o test-op) (c system))
(cons `(load-op ,(component-name c)) (call-next-method)))
;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
(defun operate (operation-class system &rest args &key (verbose t) version force
(let* ((*package* *package*)
(*readtable* *readtable*)
(op (apply #'make-instance operation-class
:original-initargs args
args))
(*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
(system (if (typep system 'component) system (find-system system))))
(unless (version-satisfies system version)
Gary King
committed
(error 'missing-component-of-version :requires system :version version))
(let ((steps (traverse op system)))
(with-compilation-unit ()
(loop :for (op . component) :in steps :do
(loop
(restart-case
(progn (perform op component)
(return))
(retry ()
:report
(lambda (s)
(format s "~@<Retry performing ~S on ~S.~@:>"
op component)))
(accept ()
:report
(lambda (s)
(format s "~@<Continue, treating ~S on ~S as ~
op component))
(setf (gethash (type-of op)
(component-operation-times component))
(get-universal-time))
(return)))))))
(defun oos (operation-class system &rest args &key force (verbose t) version
Gary King
committed
(declare (ignore force verbose version))
(apply #'operate operation-class system args))
(let ((operate-docstring
"Operate does three things:
1. It creates an instance of `operation-class` using any keyword parameters
as initargs.
2. It finds the asdf-system specified by `system` (possibly loading
it from disk).
3. It then calls `traverse` with the operation and system as arguments
The traverse operation is wrapped in `with-compilation-unit` and error
handling code. If a `version` argument is supplied, then operate also
ensures that the system found satisfies it using the `version-satisfies`
method.
Note that dependencies may cause the operation to invoke other
operations on the system or its components: the new operations will be
created with the same initargs as the original one.
"))
(setf (documentation 'oos 'function)
(format nil
"Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
operate-docstring))
(setf (documentation 'operate 'function)
(defun load-system (system &rest args &key force (verbose t) version)
"Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details."
(declare (ignore force verbose version))
(apply #'operate 'load-op system args))
(defun compile-system (system &rest args &key force (verbose t) version)
"Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details."
(declare (ignore force verbose version))
(apply #'operate 'compile-op system args))
(defun test-system (system &rest args &key force (verbose t) version)
"Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details."
(declare (ignore force verbose version))
(apply #'operate 'test-op system args))
;;;; -------------------------------------------------------------------------
;;;; Defsystem
(defun determine-system-pathname (pathname pathname-supplied-p)
;; called from the defsystem macro.
;; the pathname of a system is either
;; 1. the one supplied,
;; 2. derived from the *load-truename* (see below), or
;; 3. taken from *default-pathname-defaults*
;;
;; if using *load-truename*, then we also deal with whether or not
;; to resolve symbolic links. If not resolving symlinks, then we use
;; *load-pathname* instead of *load-truename* since in some
;; implementations, the latter has *already resolved it.
(or (and pathname-supplied-p pathname)
(if *resolve-symlinks*
(resolve-symlinks *load-truename*)
*load-pathname*)))
*default-pathname-defaults*))
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
options
(let ((component-options (remove-keyword :class options)))
;; system must be registered before we parse the body, otherwise
;; we recur when trying to find an existing system of the same name
;; to reuse options (e.g. pathname) from
(let ((s (system-registered-p ',name)))
(cond ((and s (eq (type-of (cdr s)) ',class))
(setf (car s) (get-universal-time)))
(s
(change-class (cdr s) ',class))
(t
(register-system (quote ,name)
(make-instance ',class :name ',name))))
(%set-system-source-file *load-truename*
nil (apply
#'list
:module (coerce-name ',name)
:pathname
,(determine-system-pathname pathname pathname-arg-p)
',component-options))))))
(defun class-for-type (parent type)
(let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
Gary King
committed
(load-time-value
(class (dolist (symbol (if (keywordp type)
extra-symbols
(cons type extra-symbols)))
(find-class symbol nil)
(subtypep symbol 'component))
(return (find-class symbol))))))
(and (eq type :file)
(or (module-default-component-class parent)
(find-class 'cl-source-file)))
(sysdef-error "~@<don't recognize component type ~A~@:>" type))))
(defun maybe-add-tree (tree op1 op2 c)
"Add the node C at /OP1/OP2 in TREE, unless it's there already.
Returns the new tree (which probably shares structure with the old one)"
(let ((first-op-tree (assoc op1 tree)))
(if first-op-tree
(progn
(aif (assoc op2 (cdr first-op-tree))
(if (find c (cdr it))
nil
(setf (cdr it) (cons c (cdr it))))
(setf (cdr first-op-tree)
(acons op2 (list c) (cdr first-op-tree))))
tree)
(acons op1 (list (list op2 c)) tree))))
(defun union-of-dependencies (&rest deps)
(let ((new-tree nil))
(dolist (dep deps)
(dolist (op-tree dep)
(dolist (op (cdr op-tree))
(dolist (c (cdr op))
(setf new-tree
(maybe-add-tree new-tree (car op-tree) (car op) c))))))
(defvar *serial-depends-on*)
(defun sysdef-error-component (msg type name value)
(sysdef-error (concatenate 'string msg
"~&The value specified for ~(~A~) ~A is ~W")
type name value))
(defun check-component-input (type name weakly-depends-on
"A partial test of the values of a component."
(unless (listp depends-on)
(sysdef-error-component ":depends-on must be a list."
type name depends-on))
(unless (listp weakly-depends-on)
(sysdef-error-component ":weakly-depends-on must be a list."
type name weakly-depends-on))
(unless (listp components)
(sysdef-error-component ":components must be NIL or a list of components."
type name components))
(unless (and (listp in-order-to) (listp (car in-order-to)))
(sysdef-error-component ":in-order-to must be NIL or a list of components."
type name in-order-to)))
(defun %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
;; methods will not be for this particular gf n
;; But this is hardly performance-critical
(lambda (m)
(remove-method (symbol-function name) m))
(component-inline-methods component)))
;; clear methods, then add the new ones
(setf (component-inline-methods component) nil))
(defun %define-component-inline-methods (ret rest)
(dolist (name +asdf-methods+)
(let ((keyword (intern (symbol-name name) :keyword)))
(loop :for data = rest :then (cddr data)
:for key = (first data)
:for value = (second data)
:while data
:when (eq key keyword) :do
(destructuring-bind (op qual (o c) &body body) value
(pushnew
(eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
,@body))
(component-inline-methods ret)))))))
(defun %refresh-component-inline-methods (component rest)
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest))
(defun parse-component-form (parent options)
Gary King
committed
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
components pathname default-component-class
perform explain output-files operation-done-p
weakly-depends-on
depends-on serial in-order-to
;; list ends
&allow-other-keys) options
(declare (ignorable perform explain output-files operation-done-p))
(check-component-input type name weakly-depends-on depends-on components in-order-to)
(when (and parent
(find-component parent name)
;; ignore the same object when rereading the defsystem
(not
(typep (find-component parent name)
(class-for-type parent type))))
(error 'duplicate-names :name name))
(let* ((other-args (remove-keys
'(components pathname default-component-class
perform explain output-files operation-done-p
weakly-depends-on
depends-on serial in-order-to)
rest))
(ret
(or (find-component parent name)
(make-instance (class-for-type parent type)))))
(setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
(when (boundp '*serial-depends-on*)
(setf depends-on
(concatenate 'list *serial-depends-on* depends-on)))
(apply #'reinitialize-instance ret
:name (coerce-name name)
:pathname pathname
:parent parent
other-args)
(when (typep ret 'module)
(setf (module-default-component-class ret)
(or default-component-class
(and (typep parent 'module)
(module-default-component-class parent))))
(let ((*serial-depends-on* nil))
(setf (module-components ret)
(loop :for c-form :in components
:for c = (parse-component-form ret c-form)
:collect c
:if serial
:do (push (component-name c) *serial-depends-on*))))
;; check for duplicate names
(let ((name-hash (make-hash-table :test #'equal)))
(loop :for c in (module-components ret) :do
(if (gethash (component-name c)
name-hash)
(error 'duplicate-names
:name (component-name c))
(setf (gethash (component-name c)
name-hash)
t)))))
Francois-Rene Rideau
committed
(setf (component-in-order-to ret)
(union-of-dependencies
in-order-to
`((compile-op (compile-op ,@depends-on))
(load-op (load-op ,@depends-on))))
Francois-Rene Rideau
committed
(component-do-first ret) `((compile-op (load-op ,@depends-on))))
Gary King
committed
ret)))
Francois-Rene Rideau
committed
;;;; ---------------------------------------------------------------------------
;;;; run-shell-command
;;;;
;;;; run-shell-command functions for other lisp implementations will be
;;;; gratefully accepted, if they do the same thing.
;;;; If the docstring is ambiguous, send a bug report.
Francois-Rene Rideau
committed
;;;;
;;;; We probably should move this functionality to its own system and deprecate
;;;; use of it from the asdf package. However, this would break unspecified
;;;; existing software, so until a clear alternative exists, we can't deprecate
;;;; it, and even after it's been deprecated, we will support it for a few
;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
"Interpolate `args` into `control-string` as if by `format`, and
synchronously execute the result using a Bourne-compatible shell, with
output to `*verbose-out*`. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
#+sbcl
(apply #'sb-ext:run-program
#+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*
#+win32 '(:search t) #-win32 nil))
#+(or cmu scl)

Daniel Barlow
committed
:input nil :output *verbose-out*))
#+allegro
;; will this fail if command has embedded quotes - it seems to work
(multiple-value-bind (stdout stderr exit-code)
(excl.osi:command-output
(format nil "~a -c \"~a\""
#+mswindows "sh" #-mswindows "/bin/sh" command)
:input nil :whole nil
#+mswindows :show-window #+mswindows :hide)
(format *verbose-out* "~{~&; ~a~%~}~%" stderr)
(format *verbose-out* "~{~&; ~a~%~}~%" stdout)
exit-code)
#+lispworks
(system:call-system-showing-output
command
:shell-type "/bin/sh"

Daniel Barlow
committed
:output-stream *verbose-out*)
#+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
#+openmcl
(nth-value 1
(ccl:external-process-status
(ccl:run-program "/bin/sh" (list "-c" command)
:input nil :output *verbose-out*
:wait t)))
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(si:system command)
#-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
(error "RUN-SHELL-COMMAND not implemented for this Lisp")
Francois-Rene Rideau
committed
;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname
(defmethod system-source-file ((system-name t))
(system-source-file (find-system system-name)))
(defun system-source-directory (system-name)
(make-pathname :name nil
:type nil
:defaults (system-source-file system-name)))
Francois-Rene Rideau
committed
(defun relativize-directory (directory)
(if (eq (car directory) :absolute)
(cons :relative (cdr directory))
directory))
(defun relativize-pathname-directory (pathspec)
(let ((p (pathname pathspec)))
(make-pathname
:directory (relativize-directory (pathname-directory p))
:defaults p)))
(defun system-relative-pathname (system pathname &key name type)
(let ((directory (pathname-directory pathname)))
(merge-pathnames
(make-pathname :name (or name (pathname-name pathname))
:type (or type (pathname-type pathname))
Francois-Rene Rideau
committed
:directory (relativize-directory directory))
(system-source-directory system))))
Francois-Rene Rideau
committed
;;; ---------------------------------------------------------------------------
Francois-Rene Rideau
committed
;;; implementation-identifier
Francois-Rene Rideau
committed
;;; produce a string to identify current implementation.
;;; Initially stolen from SLIME's SWANK, hacked since.
(defparameter *implementation-features*
Francois-Rene Rideau
committed
'(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
:corman :cormanlisp :armedbear :gcl :ecl :scl))
(defparameter *os-features*
Francois-Rene Rideau
committed
'((:windows :mswindows :win32 :mingw32)
(:solaris :sunos)
:macosx :darwin :apple
:freebsd :netbsd :openbsd :bsd
:linux :unix))
(defparameter *architecture-features*
Francois-Rene Rideau
committed
'((:x86-64 :amd64 :x86_64 :x8664-target)
(:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
:hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc))