Author: hhubner Date: 2007-10-20 13:32:49 -0400 (Sat, 20 Oct 2007) New Revision: 2243 Modified: branches/bos/thirdparty/asdf/asdf.lisp Log: revert to older asdf on this branch as the current one does not play nice with cxml Modified: branches/bos/thirdparty/asdf/asdf.lisp =================================================================== --- branches/bos/thirdparty/asdf/asdf.lisp 2007-10-20 17:22:25 UTC (rev 2242) +++ branches/bos/thirdparty/asdf/asdf.lisp 2007-10-20 17:32:49 UTC (rev 2243) @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.110 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ ;;; ;;; 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-2007 Daniel Barlow and contributors +;;; Copyright (c) 2001-2003 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,10 +78,7 @@ #:system-author #:system-maintainer #:system-license - #:system-licence - #:system-source-file - #:system-relative-pathname - + #:operation-on-warnings #:operation-on-failure @@ -93,29 +90,24 @@ #:*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.110 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -125,14 +117,10 @@ :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 @@ -168,9 +156,6 @@ (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) @@ -183,7 +168,7 @@ ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s "~@<erred while invoking ~A on ~A~@:>" + (format s (formatter "~@<erred while invoking ~A on ~A~@:>") (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) @@ -214,8 +199,9 @@ ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s "~@<~A, required by ~A~@:>" - (call-next-method c nil) (missing-required-by c))) + (format s (formatter "~@<~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)) @@ -223,9 +209,9 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "~@<component ~S not found~ - ~@[ or does not match version ~A~]~ - ~@[ in ~A~]~@:>" + (format s (formatter "~@<component ~S not found~ + ~@[ or does not match version ~A~]~ + ~@[ in ~A~]~@:>") (missing-requires c) (missing-version c) (when (missing-parent c) @@ -295,8 +281,7 @@ :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 - :accessor system-license :initarg :license))) + (licence :accessor system-licence :initarg :licence))) ;;; version-satisfies @@ -341,7 +326,8 @@ (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error "~@<invalid component designator ~A~@:>" name)))) + (t (sysdef-error (formatter "~@<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- @@ -370,14 +356,6 @@ (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)) @@ -386,18 +364,15 @@ (when (and on-disk (or (not in-memory) (< (car in-memory) (file-write-date on-disk)))) - (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. + (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. on-disk *package*) - (load on-disk)) - (delete-package package)))) + (load on-disk))) (let ((in-memory (gethash name *defined-systems*))) (if in-memory (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) @@ -405,7 +380,8 @@ (if error-p (error 'missing-component :requires name)))))) (defun register-system (name system) - (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) + (format *verbose-out* + (formatter "~&~@<; ~@;registering ~A as ~A~@:>~%") system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) @@ -451,20 +427,17 @@ (defmethod source-file-type ((c static-file) (s module)) nil) (defmethod component-relative-pathname ((component source-file)) - (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)))) + (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations @@ -564,26 +537,8 @@ (member node (operation-visiting-nodes (operation-ancestor o)) :test 'equal))) -(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: +(defgeneric component-depends-on (operation component)) - (<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)))) @@ -612,40 +567,26 @@ (defmethod input-files ((operation operation) (c module)) nil) (defmethod operation-done-p ((o operation) (c component)) - (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))))))))) + (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)) )))))) ;;; So you look at this code and think "why isn't it a bunch of ;;; methods". And the answer is, because standard method combination @@ -735,15 +676,16 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "~@<required method PERFORM not implemented ~ - for operation ~A, component ~A~@:>" + (formatter "~@<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 @@ -759,39 +701,38 @@ (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time)) - (load-preferences c operation)) + (get-universal-time))) ;;; 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 - "~@<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 + (formatter "~@<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 - "~@<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 + (formatter "~@<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)) - #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) - #+:broken-fasl-loader (list (component-pathname c))) + (list (compile-file-pathname (component-pathname c)))) (defmethod perform ((operation compile-op) (c static-file)) nil) @@ -799,16 +740,10 @@ (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 (operation) ()) -(defclass load-op (basic-load-op) ()) - (defmethod perform ((o load-op) (c cl-source-file)) (mapcar #'load (input-files o c))) @@ -826,7 +761,7 @@ ;;; load-source-op -(defclass load-source-op (basic-load-op) ()) +(defclass load-source-op (operation) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) (let ((source (component-pathname c))) @@ -861,103 +796,46 @@ (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 -(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) +(defun operate (operation-class system &rest args) (let* ((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) - (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))))))))) + :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)))))))) -(setf (documentation 'operate 'function) - *operate-docstring*) +(defun oos (&rest args) + "Alias of OPERATE function" + (apply #'operate args)) -(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 @@ -993,30 +871,22 @@ :module (coerce-name ',name) :pathname (or ,pathname - (when *load-truename* - (pathname-sans-name+type - (resolve-symlinks *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*) - (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)))))) + (let ((class (find-class + (or (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) #.*package*)) nil))) (or class (and (eq type :file) (or (module-default-component-class parent) (find-class 'cl-source-file))) - (sysdef-error "~@<don't recognize component type ~A~@:>" type)))) + (sysdef-error (formatter "~@<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. @@ -1053,42 +923,27 @@ (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 - (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)) - + (check-component-input type name depends-on components in-order-to) (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) @@ -1106,19 +961,7 @@ 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))))) + do (push (component-name c) *serial-depends-on*))))) (setf (slot-value ret 'in-order-to) (union-of-dependencies @@ -1127,39 +970,28 @@ (load-op (load-op ,@depends-on)))) (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - (%remove-component-inline-methods ret rest) - + (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)))) ret))) -(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) +(defun check-component-input (type name 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)) @@ -1186,15 +1018,14 @@ (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-ext:process-exit-code + (sb-impl::process-exit-code (sb-ext:run-program - #+win32 "sh" #-win32 "/bin/sh" + "/bin/sh" (list "-c" command) - #+win32 #+win32 :search t :input nil :output *verbose-out*)) #+(or cmu scl) @@ -1222,9 +1053,8 @@ (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) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) @@ -1236,29 +1066,7 @@ (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 @@ -1276,24 +1084,14 @@ (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))))) + (pushnew + '(merge-pathnames "systems/" + (truename (sb-ext:posix-getenv "SBCL_HOME"))) + *central-registry*) (pushnew - '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) - (when home - (merge-pathnames "site-systems/" (truename home)))) + '(merge-pathnames "site-systems/" + (truename (sb-ext:posix-getenv "SBCL_HOME"))) *central-registry*) (pushnew @@ -1301,8 +1099,6 @@ (user-homedir-pathname)) *central-registry*) - (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) - (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)) (provide 'asdf) -