Newer
Older
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))
(defclass compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
:initform *compile-file-warnings-behaviour*)
:initform *compile-file-failure-behaviour*)))
(defmethod perform :before ((operation compile-op) (c source-file))
(map nil #'ensure-directories-exist (output-files operation c)))
(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))))
(compile-file source-file :output-file output-file)
(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))
#-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
#+: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)
(defclass basic-load-op (operation) ())
(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
(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
(try-recompiling "Recompile ~a and try loading it again"
Gary King
committed
(component-name c))
(setf state :failed-load)
(call-next-method)
(setf state :success)))))))
(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
(try-recompiling "Try recompiling ~a"
Gary King
committed
(component-name c))
(setf state :failed-compile)
(call-next-method)
(setf state :success)))))))
(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
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
(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
(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)
(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 ~
having been successful.~@:>"
op component))
(setf (gethash (type-of op)
(component-operation-times component))
(get-universal-time))
(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.
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)
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)))
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
(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)
(when *load-truename*
(pathname-sans-name+type
(if *resolve-symlinks*
#-allegro (truename *load-truename*)
#+allegro (excl:pathname-resolve-symbolic-links *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*
(cdr (system-registered-p ',name))))
(parse-component-form
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))))))
(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*)
(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."
(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)
(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))
;; clear methods, then add the new ones
(setf (component-inline-methods component) nil))
(defun %define-component-inline-methods (ret rest)
(loop for name in +asdf-methods+ do
(let ((keyword (intern (symbol-name name) :keyword)))
(loop for data = rest then (cddr data)
for key = (and data (first data))
for value = (and data (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)
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
(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
ret)))
;;; 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
(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-PROGRAM not implemented for this Lisp")
))
(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)))
(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))))
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
;;;; Windows shortcut support. Based on:
;;; Jesse Hager: The Windows Shortcut File Format.
;;; http://www.wotsit.org/list.asp?fc=13
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
(defun read-null-terminated-string (s)
(with-output-to-string (out)
(loop
for code = (read-byte s)
until (zerop code)
do (write-char (code-char code) out))))
(defun read-little-endian (s &optional (bytes 4))
(let ((result 0))
(loop
for i from 0 below bytes
do
(setf result (logior result (ash (read-byte s) (* 8 i)))))
result))
(defun parse-windows-shortcut (pathname)
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(handler-case
(when (and (= (read-little-endian s) *link-initial-dword*)
(let ((header (make-array (length *link-guid*))))
(read-sequence header s)
(equalp header *link-guid*)))
(let ((flags (read-little-endian s)))
(file-position s 76) ;skip rest of header
(when (logbitp 0 flags)
;; skip shell item id list
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(cond
((logbitp 1 flags)
(parse-file-location-info s))
(t
(when (logbitp 2 flags)
;; skip description string
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(when (logbitp 3 flags)
;; finally, our pathname
(let* ((length (read-little-endian s 2))
(buffer (make-array length)))
(read-sequence buffer s)
(map 'string #'code-char buffer)))))))
(end-of-file ()
nil))))
(defun parse-file-location-info (s)
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
(fli-flags (read-little-endian s))
(local-volume-offset (read-little-endian s))
(local-offset (read-little-endian s))
(network-volume-offset (read-little-endian s))
(remaining-offset (read-little-endian s)))
(declare (ignore total-length end-of-header local-volume-offset))
(unless (zerop fli-flags)
(cond
((logbitp 0 fli-flags)
(file-position s (+ start local-offset)))
((logbitp 1 fli-flags)
(file-position s (+ start
network-volume-offset
#x14))))
(concatenate 'string
(read-null-terminated-string s)
(progn
(file-position s (+ start remaining-offset))
(read-null-terminated-string s))))))
#+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)