Newer
Older
(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*)
(find-symbol (symbol-name type)
Gary King
committed
(load-time-value
(package-name :asdf)))))
(class (dolist (symbol (if (keywordp type)
extra-symbols
(cons type extra-symbols)))
(when (and symbol
(find-class symbol nil)
(subtypep symbol 'component))
(return (find-class symbol))))))
(or class
(and (eq type :file)
(or (module-default-component-class parent)
(find-class 'cl-source-file)))
Christophe Rhodes
committed
(sysdef-error "~@<don't recognize component type ~A~@:>" type))))
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
(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))))))
new-tree))
(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 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
depends-on serial in-order-to
Gary King
committed
(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
depends-on serial in-order-to)
rest))
(ret
(or (find-component parent name)
(make-instance (class-for-type parent type)))))
(when weakly-depends-on
(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)))))
(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)))
Gary King
committed
(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 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 sysdef-error-component (msg type name value)
(sysdef-error (concatenate 'string msg
"~&The value specified for ~(~A~) ~A is ~W")
type name value))
(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)))

Daniel Barlow
committed
(format *verbose-out* "; $ ~A~%" command)
#+sbcl

Daniel Barlow
committed
:input nil :output *verbose-out*))
#+(or cmu scl)
(ext:process-exit-code
(ext:run-program
"/bin/sh"
(list "-c" command)

Daniel Barlow
committed
:input nil :output *verbose-out*))
#+allegro

Daniel Barlow
committed
(excl:run-shell-command command :input nil :output *verbose-out*)
#+lispworks
(system:call-system-showing-output
command
:shell-type "/bin/sh"

Daniel Barlow
committed
:output-stream *verbose-out*)

Daniel Barlow
committed
#+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)

Daniel Barlow
committed
: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 hyperdocumentation (package name doc-type))
(defmethod hyperdocumentation ((package symbol) name doc-type)
(hyperdocumentation (find-package package) name doc-type))
(defun hyperdoc (name doc-type)
(hyperdocumentation (symbol-package name) name doc-type))
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
(defun system-source-file (system-name)
(let ((system (asdf:find-system system-name)))
(make-pathname
:type "asd"
:name (asdf:component-name system)
:defaults (asdf:component-relative-pathname system))))
(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)
(let ((directory (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")))
(when 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")))
(when home
(merge-pathnames "site-systems/" (truename home))))
*central-registry*)
(pushnew

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*))
(provide 'asdf)