[bknr-cvs] r2243 - branches/bos/thirdparty/asdf
bknr at bknr.net
bknr at bknr.net
Sat Oct 20 17:32:49 UTC 2007
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 at 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 , at depends-on))))
(slot-value ret 'do-first) `((compile-op (load-op , at 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)))
+ , at 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)))
- , at 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)
-
More information about the Bknr-cvs
mailing list