Newer
Older

Kevin Rosenberg
committed
(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
(slot-value c 'in-order-to)))))
(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))
(> (file-write-date (component-pathname c))
(component-property c 'last-loaded-as-source)))

Kevin Rosenberg
committed
nil t))
(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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 ~
having been successful.~@:>"
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
&allow-other-keys)
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."))
(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)
operate-docstring))
(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))
(defun remove-keyword (key arglist)
(labels ((aux (key arglist)
(cond ((null arglist) nil)
((eq key (car arglist)) (cddr arglist))
(t (cons (car arglist) (cons (cadr arglist)
(remove-keyword
key (cddr arglist))))))))
(aux key arglist)))
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
options
(let ((component-options (remove-keyword :class options)))
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
;; 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)))))
(parse-component-form nil (apply
#'list
:module (coerce-name ',name)
:pathname
;; to avoid a note about unreachable code
,(if pathname-arg-p
pathname
`(or (when *load-truename*
(pathname-sans-name+type
(resolve-symlinks
*load-truename*)))
*default-pathname-defaults*))
',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))))))
(defun remove-keys (key-names args)
(loop for ( name val ) on args by #'cddr
unless (member (symbol-name name) key-names
:key #'symbol-name :test 'equal)
append (list name val)))
(defvar *serial-depends-on*)
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
(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 depends-on components in-order-to)
"A partial test of the values of a component."
(when weakly-depends-on (warn "We got one! XXXXX"))
(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 (ret rest)
(loop for name in +asdf-methods+
do (map 'nil
;; 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 ret)))
;; clear methods, then add the new ones
(setf (component-inline-methods ret) nil)
(loop for name in +asdf-methods+
for v = (getf rest (intern (symbol-name name) :keyword))
when v do
(destructuring-bind (op qual (o c) &body body) v
(pushnew
(eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
,@body))
(component-inline-methods ret)))))
(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)
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
(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)))))
(setf (slot-value ret 'in-order-to)
(union-of-dependencies
in-order-to
`((compile-op (compile-op ,@depends-on))
(load-op (load-op ,@depends-on))))
(slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
Gary King
committed
(%remove-component-inline-methods ret rest)
ret)))
(defun resolve-symlinks (path)
#-allegro (truename path)
#+allegro (excl:pathname-resolve-symbolic-links path)
)
;;; 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
"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

Daniel Barlow
committed
:input nil :output *verbose-out*))
#+(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-PROGRAM not implemented for this Lisp")
))
(defgeneric system-source-file (system)
(:documentation "Return the source file in which system is defined."))
(defmethod system-source-file ((system-name t))
(system-source-file (find-system system-name)))
(defmethod system-source-file ((system system))
(let ((pn (and (slot-boundp system 'relative-pathname)
(make-pathname
:type "asd"
:name (asdf:component-name system)
:defaults (asdf:component-relative-pathname system)))))
(when pn
(probe-file pn))))
(defun system-source-directory (system-name)
(make-pathname :name nil
:type nil
:defaults (system-source-file system-name)))
(defun system-relative-pathname (system pathname &key name type)
;; you're not allowed to muck with the return value of pathname-X
(let ((directory (copy-list (pathname-directory pathname))))
(when (eq (car directory) :absolute)
(setf (car directory) :relative))
(merge-pathnames
(make-pathname :name (or name (pathname-name pathname))
:type (or type (pathname-type pathname))
:directory directory)
(system-source-directory system))))
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
(pushnew :sbcl-hooks-require *features*)))
#+(and sbcl sbcl-hooks-require)
(progn
(defun module-provide-asdf (name)

Daniel Barlow
committed
(handler-bind ((style-warning #'muffle-warning))
(let* ((*verbose-out* (make-broadcast-stream))
(system (asdf:find-system name nil)))
(when system
(asdf:operate 'asdf:load-op name)
t))))
(defun contrib-sysdef-search (system)
(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
(let* ((name (coerce-name system))
(home (truename home))
(contrib (merge-pathnames
(make-pathname :directory `(:relative ,name)
:name name
:type "asd"
:case :local
:version :newest)
home)))
(probe-file contrib)))))
'(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
(merge-pathnames "site-systems/" (truename home))))

Daniel Barlow
committed
'(merge-pathnames ".sbcl/systems/"
(user-homedir-pathname))
(pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
(pushnew 'contrib-sysdef-search *system-definition-search-functions*))
(if *asdf-revision*
(asdf-message ";; ASDF, revision ~a" *asdf-revision*)
(asdf-message ";; ASDF, revision unknown; possibly a development version"))
(provide 'asdf)