Author: hhubner Date: 2007-10-04 03:23:42 -0400 (Thu, 04 Oct 2007) New Revision: 2179 Modified: branches/bos/thirdparty/asdf/asdf.lisp Log: Update asdf to current cclan version. Modified: branches/bos/thirdparty/asdf/asdf.lisp =================================================================== --- branches/bos/thirdparty/asdf/asdf.lisp 2007-10-03 01:20:42 UTC (rev 2178) +++ branches/bos/thirdparty/asdf/asdf.lisp 2007-10-04 07:23:42 UTC (rev 2179) @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.110 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list@lists.sf.net>. But note first that the canonical @@ -13,7 +13,7 @@ ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' -;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; Copyright (c) 2001-2007 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -78,7 +78,10 @@ #:system-author #:system-maintainer #:system-license - + #:system-licence + #:system-source-file + #:system-relative-pathname + #:operation-on-warnings #:operation-on-failure @@ -90,24 +93,29 @@ #:*asdf-revision* #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation #:system-definition-error #:missing-component #:missing-dependency #:circular-dependency ; errors - + #:duplicate-names + #:retry #:accept ; restarts + #:preference-file-for-system/operation + #:load-preferences ) (:use :cl)) + #+nil (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.110 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -117,10 +125,14 @@ :junk-allowed t))))) (defvar *compile-file-warnings-behaviour* :warn) + (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *verbose-out* nil) +(defparameter +asdf-methods+ + '(perform explain output-files operation-done-p)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff @@ -156,6 +168,9 @@ (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name))) + (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (version :initform nil :reader missing-version :initarg :version) @@ -168,7 +183,7 @@ ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s (formatter "~@<erred while invoking ~A on ~A~@:>") + (format s "~@<erred while invoking ~A on ~A~@:>" (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) @@ -199,9 +214,8 @@ ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s (formatter "~@<~A, required by ~A~@:>") - (call-next-method c nil) - (missing-required-by c))) + (format s "~@<~A, required by ~A~@:>" + (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) @@ -209,9 +223,9 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s (formatter "~@<component ~S not found~ - ~@[ or does not match version ~A~]~ - ~@[ in ~A~]~@:>") + (format s "~@<component ~S not found~ + ~@[ or does not match version ~A~]~ + ~@[ in ~A~]~@:>" (missing-requires c) (missing-version c) (when (missing-parent c) @@ -281,7 +295,8 @@ :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) - (licence :accessor system-licence :initarg :licence))) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license))) ;;; version-satisfies @@ -326,8 +341,7 @@ (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error (formatter "~@<invalid component designator ~A~@:>") - name)))) + (t (sysdef-error "~@<invalid component designator ~A~@:>" name)))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- @@ -356,6 +370,14 @@ (if (and file (probe-file file)) (return file))))))) +(defun make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) (defun find-system (name &optional (error-p t)) (let* ((name (coerce-name name)) @@ -364,15 +386,18 @@ (when (and on-disk (or (not in-memory) (< (car in-memory) (file-write-date on-disk)))) - (let ((*package* (make-package (gensym (package-name #.*package*)) - :use '(:cl :asdf)))) - (format *verbose-out* - (formatter "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%") - ;; FIXME: This wants to be (ENOUGH-NAMESTRING - ;; ON-DISK), but CMUCL barfs on that. + (let ((package (make-temporary-package))) + (unwind-protect + (let ((*package* package)) + (format + *verbose-out* + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + ;; FIXME: This wants to be (ENOUGH-NAMESTRING + ;; ON-DISK), but CMUCL barfs on that. on-disk *package*) - (load on-disk))) + (load on-disk)) + (delete-package package)))) (let ((in-memory (gethash name *defined-systems*))) (if in-memory (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) @@ -380,8 +405,7 @@ (if error-p (error 'missing-component :requires name)))))) (defun register-system (name system) - (format *verbose-out* - (formatter "~&~@<; ~@;registering ~A as ~A~@:>~%") system name) + (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) @@ -427,17 +451,20 @@ (defmethod source-file-type ((c static-file) (s module)) nil) (defmethod component-relative-pathname ((component source-file)) - (let* ((*default-pathname-defaults* (component-parent-pathname component)) - (name-type - (make-pathname - :name (component-name component) - :type (source-file-type component - (component-system component))))) - (if (slot-value component 'relative-pathname) - (merge-pathnames - (slot-value component 'relative-pathname) - name-type) - name-type))) + (let ((relative-pathname (slot-value component 'relative-pathname))) + (if relative-pathname + (merge-pathnames + relative-pathname + (make-pathname + :type (source-file-type component (component-system component)))) + (let* ((*default-pathname-defaults* + (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + name-type)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations @@ -537,8 +564,26 @@ (member node (operation-visiting-nodes (operation-ancestor o)) :test 'equal))) -(defgeneric component-depends-on (operation component)) +(defgeneric component-depends-on (operation component) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + (<operation> <component>*), where <operation> is a class + designator and each <component> is a component + designator, which means that the component depends on + <operation> having been performed on each <component>; or + + (FEATURE <feature>), which means that the component depends + on <feature>'s presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(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)) (slot-value c 'in-order-to)))) @@ -567,26 +612,40 @@ (defmethod input-files ((operation operation) (c module)) nil) (defmethod operation-done-p ((o operation) (c component)) - (let ((out-files (output-files o c)) - (in-files (input-files o c))) - (cond ((and (not in-files) (not out-files)) - ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much - t) - ((not out-files) - (let ((op-done - (gethash (type-of o) - (component-operation-times c)))) - (and op-done - (>= op-done - (or (apply #'max - (mapcar #'file-write-date in-files)) 0))))) - ((not in-files) nil) - (t - (and - (every #'probe-file out-files) - (> (apply #'min (mapcar #'file-write-date out-files)) - (apply #'max (mapcar #'file-write-date in-files)) )))))) + (flet ((fwd-or-return-t (file) + ;; if FILE-WRITE-DATE returns NIL, it's possible that the + ;; user or some other agent has deleted an input file. If + ;; that's the case, well, that's not good, but as long as + ;; the operation is otherwise considered to be done we + ;; could continue and survive. + (let ((date (file-write-date file))) + (cond + (date) + (t + (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~ + operation ~S on component ~S as done.~@:>" + file o c) + (return-from operation-done-p t)))))) + (let ((out-files (output-files o c)) + (in-files (input-files o c))) + (cond ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (apply #'max + (mapcar #'fwd-or-return-t in-files)))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) ;;; So you look at this code and think "why isn't it a bunch of ;;; methods". And the answer is, because standard method combination @@ -676,16 +735,15 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - (formatter "~@<required method PERFORM not implemented~ - for operation ~A, component ~A~@:>") + "~@<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)) - (format *verbose-out* "~&;;; ~A on ~A~%" - operation component)) + (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) ;;; compile-op @@ -701,38 +759,39 @@ (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time))) + (get-universal-time)) + (load-preferences c operation)) ;;; 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)) + #-:broken-fasl-loader (let ((source-file (component-pathname c)) - (output-file (car (output-files operation c)))) + (output-file (car (output-files operation c)))) (multiple-value-bind (output warnings-p failure-p) - (compile-file source-file - :output-file output-file) + (compile-file source-file + :output-file output-file) ;(declare (ignore output)) (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - (formatter "~@<COMPILE-FILE warned while ~ - performing ~A on ~A.~@:>") - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (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))) (when failure-p - (case (operation-on-failure operation) - (:warn (warn - (formatter "~@<COMPILE-FILE failed while ~ - performing ~A on ~A.~@:>") - operation c)) - (:error (error 'compile-failed :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))))) + (error 'compile-error :component c :operation operation))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) - (list (compile-file-pathname (component-pathname c)))) + #-: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) @@ -740,10 +799,16 @@ (defmethod output-files ((operation compile-op) (c static-file)) nil) +(defmethod input-files ((op compile-op) (c static-file)) + nil) + + ;;; load-op -(defclass load-op (operation) ()) +(defclass basic-load-op (operation) ()) +(defclass load-op (basic-load-op) ()) + (defmethod perform ((o load-op) (c cl-source-file)) (mapcar #'load (input-files o c))) @@ -761,7 +826,7 @@ ;;; load-source-op -(defclass load-source-op (operation) ()) +(defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) (let ((source (component-pathname c))) @@ -796,46 +861,103 @@ (defmethod perform ((operation test-op) (c component)) nil) +(defgeneric load-preferences (system operation) + (:documentation "Called to load system preferences after <perform operation system>. Typical uses are to set parameters that don't exist until after the system has been loaded.")) + +(defgeneric preference-file-for-system/operation (system operation) + (:documentation "Returns the pathname of the preference file for this system. Called by 'load-preferences to determine what file to load.")) + +(defmethod load-preferences ((s t) (operation t)) + ;; do nothing + (values)) + +(defmethod load-preferences ((s system) (operation basic-load-op)) + (let* ((*package* (find-package :common-lisp)) + (file (probe-file (preference-file-for-system/operation s operation)))) + (when file + (when *verbose-out* + (format *verbose-out* + "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%" + (component-name s) + (type-of operation) file)) + (load file)))) + +(defmethod preference-file-for-system/operation ((system t) (operation t)) + ;; cope with anything other than systems + (preference-file-for-system/operation (find-system system t) operation)) + +(defmethod preference-file-for-system/operation ((s system) (operation t)) + (let ((*default-pathname-defaults* + (make-pathname :name nil :type nil + :defaults *default-pathname-defaults*))) + (merge-pathnames + (make-pathname :name (component-name s) + :type "lisp" + :directory '(:relative ".asdf")) + (truename (user-homedir-pathname))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations -(defun operate (operation-class system &rest args) +(defvar *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.") + +(defun operate (operation-class system &rest args &key (verbose t) version + &allow-other-keys) (let* ((op (apply #'make-instance operation-class - :original-initargs args args)) - (*verbose-out* - (if (getf args :verbose t) - *trace-output* - (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system))) - (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 - (formatter "~@<Retry performing ~S on ~S.~@:>") - op component))) - (accept () - :report - (lambda (s) - (format s - (formatter "~@<Continue, treating ~S on ~S as ~ - having been successful.~@:>") - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) + :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) + (error 'missing-component :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 (&rest args) - "Alias of OPERATE function" - (apply #'operate args)) +(setf (documentation 'operate 'function) + *operate-docstring*) +(defun oos (operation-class system &rest args &key force (verbose t) version) + (declare (ignore force verbose version)) + (apply #'operate operation-class system args)) + +(setf (documentation 'oos 'function) + (format nil + "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a" + *operate-docstring*)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; syntax @@ -871,22 +993,30 @@ :module (coerce-name ',name) :pathname (or ,pathname - (pathname-sans-name+type - (resolve-symlinks *load-truename*)) + (when *load-truename* + (pathname-sans-name+type + (resolve-symlinks *load-truename*))) *default-pathname-defaults*) ',component-options)))))) (defun class-for-type (parent type) - (let ((class (find-class - (or (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) #.*package*)) nil))) + (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) + (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))) - (sysdef-error (formatter "~@<don't recognize component type ~A~@:>") - type)))) + (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. @@ -923,27 +1053,42 @@ (defvar *serial-depends-on*) (defun parse-component-form (parent options) + (destructuring-bind (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 - (check-component-input type name depends-on components in-order-to) + (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))))) + (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))) + (concatenate 'list *serial-depends-on* depends-on))) (apply #'reinitialize-instance ret :name (coerce-name name) @@ -961,7 +1106,19 @@ for c = (parse-component-form ret c-form) collect c if serial - do (push (component-name c) *serial-depends-on*))))) + 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 @@ -970,28 +1127,39 @@ (load-op (load-op ,@depends-on)))) (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - (loop for (n v) in `((perform ,perform) (explain ,explain) - (output-files ,output-files) - (operation-done-p ,operation-done-p)) - 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 n) m)) - (component-inline-methods ret)) - when v - do (destructuring-bind (op qual (o c) &body body) v - (pushnew - (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret)))) + (%remove-component-inline-methods ret rest) + ret))) -(defun check-component-input (type name depends-on components 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 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)) @@ -1018,14 +1186,15 @@ (defun run-shell-command (control-string &rest args) "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." +output to *VERBOSE-OUT*. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (format *verbose-out* "; $ ~A~%" command) #+sbcl - (sb-impl::process-exit-code + (sb-ext:process-exit-code (sb-ext:run-program - "/bin/sh" + #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) + #+win32 #+win32 :search t :input nil :output *verbose-out*)) #+(or cmu scl) @@ -1053,8 +1222,9 @@ (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out* :wait t))) - - #-(or openmcl clisp lispworks allegro scl cmu sbcl) + #+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") )) @@ -1066,7 +1236,29 @@ (defun hyperdoc (name doc-type) (hyperdocumentation (symbol-package name) name doc-type)) +(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)))) + + (pushnew :asdf *features*) #+sbcl @@ -1084,14 +1276,24 @@ (asdf:operate 'asdf:load-op name) t)))) - (pushnew - '(merge-pathnames "systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) - *central-registry*) + (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))))) (pushnew - '(merge-pathnames "site-systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) + '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) + (when home + (merge-pathnames "site-systems/" (truename home)))) *central-registry*) (pushnew @@ -1099,6 +1301,8 @@ (user-homedir-pathname)) *central-registry*) - (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)) + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) + (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) (provide 'asdf) +