[PATCH] add new restart: "Retry loading component ~S."
Luis Oliveira <[email protected]> Sat, 07 Apr 2007 23:04:25 +0100
| Newsgroups | gmane.lisp.cclan.general |
|---|---|
| Message-ID | <[email protected]> |
Hello, Attached is a patch to add a RETRY restart when ASDF fails to find a dependency. I find it pretty useful. Hopefully I added the restart in the best place too. As a bonus (or maybe not), I've attached two additional patches. One removes trailing whitespace, the other replaces tabs with spaces. Feel free to ignore that last one, or both. -- Luís Oliveira http://student.dei.uc.pt/~lmoliv/ ------------------------------------------------------------------------- This SF.net email is sponsored by DB2 Express Download DB2 Express C - the FREE version of DB2 express and take control of your XML. No limits. Just data. Click to get it now. http://sourceforge.net/powerbar/db2/ _______________________________________________ cclan-list mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/cclan-list
component-load-retry.patch
(text/x-patch, 2.2 KB)
Index: asdf.lisp =================================================================== RCS file: /cvsroot/cclan/asdf/asdf.lisp,v retrieving revision 1.107 diff -u -r1.107 asdf.lisp --- asdf.lisp 21 Mar 2007 22:08:33 -0000 1.107 +++ asdf.lisp 7 Apr 2007 20:14:53 -0000 @@ -652,18 +654,28 @@ (defgeneric traverse (operation component)) (defmethod traverse ((operation operation) (c component)) (let ((forced nil)) - (labels ((do-one-dep (required-op required-c required-v) - (let* ((dep-c (or (find-component - (component-parent c) - ;; XXX tacky. really we should build the - ;; in-order-to slot with canonicalized - ;; names instead of coercing this late - (coerce-name required-c) required-v) - (error 'missing-dependency :required-by c - :version required-v - :requires required-c))) - (op (make-sub-operation c operation dep-c required-op))) - (traverse op dep-c))) + (labels ((%do-one-dep (required-op required-c required-v) + (let* ((dep-c (or (find-component + (component-parent c) + ;; XXX tacky. really we should build the + ;; in-order-to slot with canonicalized + ;; names instead of coercing this late + (coerce-name required-c) required-v) + (error 'missing-dependency :required-by c + :version required-v + :requires required-c))) + (op (make-sub-operation c operation dep-c required-op))) + (traverse op dep-c))) + (do-one-dep (required-op required-c required-v) + (loop + (restart-case + (progn (%do-one-dep required-op required-c required-v) + (return)) + (retry () + :report + (lambda (s) + (format s "~@<Retry loading component ~S.~@:>" + required-c)))))) (do-dep (op dep) (cond ((eq op 'feature) (or (member (car dep) *features*)
remove-trailing-whitespace.patch
(text/x-patch, 13.3 KB)
--- asdf.lisp.orig 2007-04-07 22:34:53.000000000 +0100
+++ asdf.lisp 2007-04-07 22:35:00.000000000 +0100
@@ -41,17 +41,17 @@
(:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
#:hyperdocumentation #:hyperdoc
-
+
#:compile-op #:load-op #:load-source-op #:test-system-version
#:test-op
#:operation ; operations
#:feature ; sort-of operation
#:version ; metaphorically sort-of an operation
-
+
#:input-files #:output-files #:perform ; operation methods
#:operation-done-p #:explain
-
- #:component #:source-file
+
+ #:component #:source-file
#:c-source-file #:cl-source-file #:java-source-file
#:static-file
#:doc-file
@@ -61,7 +61,7 @@
#:module ; components
#:system
#:unix-dso
-
+
#:module-components ; component accessors
#:component-pathname
#:component-relative-pathname
@@ -70,7 +70,7 @@
#:component-parent
#:component-property
#:component-system
-
+
#:component-depends-on
#:system-description
@@ -80,29 +80,29 @@
#:system-license
#:system-licence
#:system-source-file
- #:system-relative-pathname
+ #:system-relative-pathname
#:operation-on-warnings
#:operation-on-failure
-
- ;#:*component-parent-pathname*
+
+ ;#:*component-parent-pathname*
#:*system-definition-search-functions*
#:*central-registry* ; variables
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*asdf-revision*
-
+
#:operation-error #:compile-failed #:compile-warned #:compile-error
#:error-component #:error-operation
- #:system-definition-error
+ #:system-definition-error
#:missing-component
#:missing-dependency
#:circular-dependency ; errors
#:duplicate-names
-
+
#:retry
#:accept ; restarts
-
+
#:preference-file-for-system/operation
#:load-preferences
)
@@ -117,7 +117,7 @@
(defvar *asdf-revision* (let* ((v "$Revision: 1.107 $")
(colon (or (position #\: v) -1))
(dot (position #\. v)))
- (and v colon dot
+ (and v colon dot
(list (parse-integer v :start (1+ colon)
:junk-allowed t)
(parse-integer v :start (1+ dot)
@@ -140,8 +140,8 @@
and NIL NAME and TYPE components"
(make-pathname :name nil :type nil :defaults pathname))
-(define-modify-macro appendf (&rest args)
- append "Append onto list")
+(define-modify-macro appendf (&rest args)
+ append "Append onto list")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; classes, condiitons
@@ -260,7 +260,7 @@
(defgeneric component-relative-pathname (component)
(:documentation "Extracts the relative pathname applicable for a particular component."))
-
+
(defmethod component-relative-pathname ((component module))
(or (slot-value component 'relative-pathname)
(make-pathname
@@ -348,7 +348,7 @@
(defun system-definition-pathname (system)
(some (lambda (x) (funcall x system))
*system-definition-search-functions*))
-
+
(defvar *central-registry*
'(*default-pathname-defaults*
#+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
@@ -378,14 +378,14 @@
(defun find-system (name &optional (error-p t))
(let* ((name (coerce-name name))
(in-memory (gethash name *defined-systems*))
- (on-disk (system-definition-pathname name)))
+ (on-disk (system-definition-pathname name)))
(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
+ (format
*verbose-out*
"~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
;; FIXME: This wants to be (ENOUGH-NAMESTRING
@@ -421,7 +421,7 @@
(let ((m (find name (module-components module)
:test #'equal :key #'component-name)))
(if (and m (version-satisfies m version)) m))))
-
+
;;; a component with no parent is a system
(defmethod find-component ((module (eql nil)) name &optional version)
@@ -449,11 +449,11 @@
(defmethod component-relative-pathname ((component source-file))
(let ((relative-pathname (slot-value component 'relative-pathname)))
(if relative-pathname
- (merge-pathnames
+ (merge-pathnames
relative-pathname
- (make-pathname
+ (make-pathname
:type (source-file-type component (component-system component))))
- (let* ((*default-pathname-defaults*
+ (let* ((*default-pathname-defaults*
(component-parent-pathname component))
(name-type
(make-pathname
@@ -481,7 +481,7 @@
(prin1 (operation-original-initargs o) stream))))
(defmethod shared-initialize :after ((operation operation) slot-names
- &key force
+ &key force
&allow-other-keys)
(declare (ignore slot-names force))
;; empty method to disable initarg validity checking
@@ -520,7 +520,7 @@
:original-initargs args args))
((subtypep (type-of o) dep-o)
o)
- (t
+ (t
(apply #'make-instance dep-o
:parent o :original-initargs args args)))))
@@ -591,7 +591,7 @@
(remove-if-not (lambda (x)
(member (component-name c) (cdr x) :test #'string=))
all-deps)))
-
+
(defmethod input-files ((operation operation) (c component))
(let ((parent (component-parent c))
(self-deps (component-self-dependencies operation c)))
@@ -601,7 +601,7 @@
(output-files (make-instance op)
(find-component parent name))))
self-deps)
- ;; no previous operations needed? I guess we work with the
+ ;; no previous operations needed? I guess we work with the
;; original source file, then
(list (component-pathname c)))))
@@ -617,18 +617,18 @@
(let ((date (file-write-date file)))
(cond
(date)
- (t
+ (t
(warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
- operation ~S on component ~S as done.~@:>"
+ 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
+ ;; produce nothing probably isn't doing much
t)
- ((not out-files)
+ ((not out-files)
(let ((op-done
(gethash (type-of o)
(component-operation-times c))))
@@ -737,7 +737,6 @@
(setf (visiting-component operation c) nil)
(visit-component operation c (and forced t))
forced)))
-
(defmethod perform ((operation operation) (c source-file))
(sysdef-error
@@ -876,21 +875,21 @@
(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 file
(when *verbose-out*
- (format *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
+ ;; 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
+ (let ((*default-pathname-defaults*
+ (make-pathname :name nil :type nil
:defaults *default-pathname-defaults*)))
(merge-pathnames
(make-pathname :name (component-name s)
@@ -901,7 +900,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
-(defun operate (operation-class system &rest args &key (verbose t) version
+(defun operate (operation-class system &rest args &key (verbose t) version
&allow-other-keys)
(let* ((op (apply #'make-instance operation-class
:original-initargs args
@@ -914,7 +913,7 @@
(with-compilation-unit ()
(loop for (op . component) in steps do
(loop
- (restart-case
+ (restart-case
(progn (perform op component)
(return))
(retry ()
@@ -978,16 +977,15 @@
(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)
+ (find-symbol (symbol-name type)
(package-name #.*package*))))
(class (dolist (symbol (if (keywordp type)
extra-symbols
(cons type extra-symbols)))
- (when (and symbol
+ (when (and symbol
(find-class symbol nil)
(subtypep symbol 'component))
(return (find-class symbol))))))
@@ -1011,7 +1009,7 @@
(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)
@@ -1025,7 +1023,7 @@
(defun remove-keys (key-names args)
(loop for ( name val ) on args by #'cddr
- unless (member (symbol-name name) key-names
+ unless (member (symbol-name name) key-names
:key #'symbol-name :test 'equal)
append (list name val)))
@@ -1047,11 +1045,11 @@
(when (and parent
(find-component parent name)
;; ignore the same object when rereading the defsystem
- (not
+ (not
(typep (find-component parent name)
- (class-for-type parent type))))
+ (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
@@ -1065,7 +1063,7 @@
(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)
@@ -1096,14 +1094,14 @@
(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))))
-
+
(loop for (n v) in `((perform ,perform) (explain ,explain)
(output-files ,output-files)
(operation-done-p ,operation-done-p))
@@ -1161,12 +1159,12 @@
(format *verbose-out* "; $ ~A~%" command)
#+sbcl
(sb-ext:process-exit-code
- (sb-ext:run-program
+ (sb-ext:run-program
#+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
#+win32 #+win32 :search t
:input nil :output *verbose-out*))
-
+
#+(or cmu scl)
(ext:process-exit-code
(ext:run-program
@@ -1176,13 +1174,13 @@
#+allegro
(excl:run-shell-command command :input nil :output *verbose-out*)
-
+
#+lispworks
(system:call-system-showing-output
command
:shell-type "/bin/sh"
:output-stream *verbose-out*)
-
+
#+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
@@ -1198,7 +1196,6 @@
(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))
@@ -1208,7 +1205,7 @@
(defun system-source-file (system-name)
(let ((system (asdf:find-system system-name)))
- (make-pathname
+ (make-pathname
:type "asd"
:name (asdf:component-name system)
:defaults (asdf:component-relative-pathname system))))
@@ -1259,20 +1256,19 @@
:version :newest)
home)))
(probe-file contrib)))))
-
+
(pushnew
'(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
(when home
(merge-pathnames "site-systems/" (truename home))))
*central-registry*)
-
+
(pushnew
'(merge-pathnames ".sbcl/systems/"
(user-homedir-pathname))
*central-registry*)
-
+
(pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
(pushnew 'contrib-sysdef-search *system-definition-search-functions*))
(provide 'asdf)
-
die-tabs-die.patch
(text/x-patch, 48 KB)
--- asdf.lisp.orig 2007-04-07 22:35:30.000000000 +0100
+++ asdf.lisp 2007-04-07 22:44:35.000000000 +0100
@@ -1,3 +1,5 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+;;;
;;; This is asdf: Another System Definition Facility. $Revision: 1.107 $
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
@@ -39,89 +41,89 @@
(defpackage #:asdf
(:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
- #:system-definition-pathname #:find-component ; miscellaneous
- #:hyperdocumentation #:hyperdoc
+ #:system-definition-pathname #:find-component ; miscellaneous
+ #:hyperdocumentation #:hyperdoc
- #:compile-op #:load-op #:load-source-op #:test-system-version
- #:test-op
- #:operation ; operations
- #:feature ; sort-of operation
- #:version ; metaphorically sort-of an operation
-
- #:input-files #:output-files #:perform ; operation methods
- #:operation-done-p #:explain
-
- #:component #:source-file
- #:c-source-file #:cl-source-file #:java-source-file
- #:static-file
- #:doc-file
- #:html-file
- #:text-file
- #:source-file-type
- #:module ; components
- #:system
- #:unix-dso
-
- #:module-components ; component accessors
- #:component-pathname
- #:component-relative-pathname
- #:component-name
- #:component-version
- #:component-parent
- #:component-property
- #:component-system
-
- #:component-depends-on
-
- #:system-description
- #:system-long-description
- #:system-author
- #:system-maintainer
- #:system-license
- #:system-licence
- #:system-source-file
- #:system-relative-pathname
-
- #:operation-on-warnings
- #:operation-on-failure
-
- ;#:*component-parent-pathname*
- #:*system-definition-search-functions*
- #:*central-registry* ; variables
- #:*compile-file-warnings-behaviour*
- #:*compile-file-failure-behaviour*
- #:*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
+ #:compile-op #:load-op #:load-source-op #:test-system-version
+ #:test-op
+ #:operation ; operations
+ #:feature ; sort-of operation
+ #:version ; metaphorically sort-of an operation
+
+ #:input-files #:output-files #:perform ; operation methods
+ #:operation-done-p #:explain
+
+ #:component #:source-file
+ #:c-source-file #:cl-source-file #:java-source-file
+ #:static-file
+ #:doc-file
+ #:html-file
+ #:text-file
+ #:source-file-type
+ #:module ; components
+ #:system
+ #:unix-dso
+
+ #:module-components ; component accessors
+ #:component-pathname
+ #:component-relative-pathname
+ #:component-name
+ #:component-version
+ #:component-parent
+ #:component-property
+ #:component-system
+
+ #:component-depends-on
+
+ #:system-description
+ #:system-long-description
+ #:system-author
+ #:system-maintainer
+ #:system-license
+ #:system-licence
+ #:system-source-file
+ #:system-relative-pathname
+
+ #:operation-on-warnings
+ #:operation-on-failure
+
+ ;; #:*component-parent-pathname*
+ #:*system-definition-search-functions*
+ #:*central-registry* ; variables
+ #:*compile-file-warnings-behaviour*
+ #:*compile-file-failure-behaviour*
+ #:*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
+ #: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.107 $")
- (colon (or (position #\: v) -1))
- (dot (position #\. v)))
- (and v colon dot
- (list (parse-integer v :start (1+ colon)
- :junk-allowed t)
- (parse-integer v :start (1+ dot)
- :junk-allowed t)))))
+(defvar *asdf-revision*
+ (let* ((v "$Revision: 1.107 $")
+ (colon (or (position #\: v) -1))
+ (dot (position #\. v)))
+ (and v colon dot
+ (list (parse-integer v :start (1+ colon)
+ :junk-allowed t)
+ (parse-integer v :start (1+ dot)
+ :junk-allowed t)))))
(defvar *compile-file-warnings-behaviour* :warn)
@@ -141,10 +143,10 @@
(make-pathname :name nil :type nil :defaults pathname))
(define-modify-macro appendf (&rest args)
- append "Append onto list")
+ append "Append onto list")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; classes, condiitons
+;; classes, conditons
(define-condition system-definition-error (error) ()
;; [this use of :report should be redundant, but unfortunately it's not.
@@ -159,7 +161,7 @@
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s)
- (apply #'format s (format-control c) (format-arguments c)))))
+ (apply #'format s (format-control c) (format-arguments c)))))
(define-condition circular-dependency (system-definition-error)
((components :initarg :components :reader circular-dependency-components)))
@@ -179,15 +181,16 @@
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
- (format s "~@<erred while invoking ~A on ~A~@:>"
- (error-operation c) (error-component c)))))
+ (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) ())
(define-condition compile-warned (compile-error) ())
(defclass component ()
((name :accessor component-name :initarg :name :documentation
- "Component name: designator for a string composed of portable pathname characters")
+ "Component name: designator for a string composed of portable
+ pathname characters")
(version :accessor component-version :initarg :version)
(in-order-to :initform nil :initarg :in-order-to)
;;; XXX crap name
@@ -201,20 +204,21 @@
;; it to default in funky ways if not supplied
(relative-pathname :initarg :pathname)
(operation-times :initform (make-hash-table )
- :accessor component-operation-times)
+ :accessor component-operation-times)
;; XXX we should provide some atomic interface for updating the
;; component properties
(properties :accessor component-properties :initarg :properties
- :initform nil)))
+ :initform nil)))
;;;; methods: conditions
(defmethod print-object ((c missing-dependency) s)
(format s "~@<~A, required by ~A~@:>"
- (call-next-method c nil) (missing-required-by c)))
+ (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))
+ (error 'formatted-system-definition-error :format-control format
+ :format-arguments arguments))
;;;; methods: components
@@ -222,14 +226,14 @@
(format s "~@<component ~S not found~
~@[ or does not match version ~A~]~
~@[ in ~A~]~@:>"
- (missing-requires c)
- (missing-version c)
- (when (missing-parent c)
- (component-name (missing-parent c)))))
+ (missing-requires c)
+ (missing-version c)
+ (when (missing-parent c)
+ (component-name (missing-parent c)))))
(defgeneric component-system (component)
(:documentation "Find the top-level system containing COMPONENT"))
-
+
(defmethod component-system ((component component))
(aif (component-parent component)
(component-system it)
@@ -245,13 +249,14 @@
;; what to do if we can't satisfy a dependency of one of this module's
;; components. This allows a limited form of conditional processing
(if-component-dep-fails :initform :fail
- :accessor module-if-component-dep-fails
- :initarg :if-component-dep-fails)
+ :accessor module-if-component-dep-fails
+ :initarg :if-component-dep-fails)
(default-component-class :accessor module-default-component-class
:initform 'cl-source-file :initarg :default-component-class)))
(defgeneric component-pathname (component)
- (:documentation "Extracts the pathname applicable for a particular component."))
+ (:documentation
+ "Extracts the pathname applicable for a particular component."))
(defun component-parent-pathname (component)
(aif (component-parent component)
@@ -259,7 +264,8 @@
*default-pathname-defaults*))
(defgeneric component-relative-pathname (component)
- (:documentation "Extracts the relative pathname applicable for a particular component."))
+ (:documentation
+ "Extracts the relative pathname applicable for a particular component."))
(defmethod component-relative-pathname ((component module))
(or (slot-value component 'relative-pathname)
@@ -281,9 +287,9 @@
(defmethod (setf component-property) (new-value (c component) property)
(let ((a (assoc property (slot-value c 'properties) :test #'equal)))
(if a
- (setf (cdr a) new-value)
- (setf (slot-value c 'properties)
- (acons property new-value (slot-value c 'properties))))))
+ (setf (cdr a) new-value)
+ (setf (slot-value c 'properties)
+ (acons property new-value (slot-value c 'properties))))))
(defclass system (module)
((description :accessor system-description :initarg :description)
@@ -292,7 +298,7 @@
(author :accessor system-author :initarg :author)
(maintainer :accessor system-maintainer :initarg :maintainer)
(licence :accessor system-licence :initarg :licence
- :accessor system-license :initarg :license)))
+ :accessor system-license :initarg :license)))
;;; version-satisfies
@@ -302,13 +308,13 @@
(nreverse
(let ((list nil) (start 0) (words 0) end)
(loop
- (when (and max (>= words (1- max)))
- (return (cons (subseq string start) list)))
- (setf end (position-if #'is-ws string :start start))
- (push (subseq string start end) list)
- (incf words)
- (unless end (return list))
- (setf start (1+ end)))))))
+ (when (and max (>= words (1- max)))
+ (return (cons (subseq string start) list)))
+ (setf end (position-if #'is-ws string :start start))
+ (push (subseq string start end) list)
+ (incf words)
+ (unless end (return list))
+ (setf start (1+ end)))))))
(defgeneric version-satisfies (component version))
@@ -316,17 +322,17 @@
(unless (and version (slot-boundp c 'version))
(return-from version-satisfies t))
(let ((x (mapcar #'parse-integer
- (split (component-version c) nil '(#\.))))
- (y (mapcar #'parse-integer
- (split version nil '(#\.)))))
+ (split (component-version c) nil '(#\.))))
+ (y (mapcar #'parse-integer
+ (split version nil '(#\.)))))
(labels ((bigger (x y)
- (cond ((not y) t)
- ((not x) nil)
- ((> (car x) (car y)) t)
- ((= (car x) (car y))
- (bigger (cdr x) (cdr y))))))
+ (cond ((not y) t)
+ ((not x) nil)
+ ((> (car x) (car y)) t)
+ ((= (car x) (car y))
+ (bigger (cdr x) (cdr y))))))
(and (= (car x) (car y))
- (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+ (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding systems
@@ -347,7 +353,7 @@
(defun system-definition-pathname (system)
(some (lambda (x) (funcall x system))
- *system-definition-search-functions*))
+ *system-definition-search-functions*))
(defvar *central-registry*
'(*default-pathname-defaults*
@@ -358,13 +364,13 @@
(let ((name (coerce-name system)))
(block nil
(dolist (dir *central-registry*)
- (let* ((defaults (eval dir))
- (file (and defaults
- (make-pathname
- :defaults defaults :version :newest
- :name name :type "asd" :case :local))))
- (if (and file (probe-file file))
- (return file)))))))
+ (let* ((defaults (eval dir))
+ (file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd" :case :local))))
+ (if (and file (probe-file file))
+ (return file)))))))
(defun make-temporary-package ()
(flet ((try (counter)
@@ -377,11 +383,11 @@
(defun find-system (name &optional (error-p t))
(let* ((name (coerce-name name))
- (in-memory (gethash name *defined-systems*))
- (on-disk (system-definition-pathname name)))
+ (in-memory (gethash name *defined-systems*))
+ (on-disk (system-definition-pathname name)))
(when (and on-disk
- (or (not in-memory)
- (< (car in-memory) (file-write-date on-disk))))
+ (or (not in-memory)
+ (< (car in-memory) (file-write-date on-disk))))
(let ((package (make-temporary-package)))
(unwind-protect
(let ((*package* package))
@@ -390,20 +396,20 @@
"~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
;; FIXME: This wants to be (ENOUGH-NAMESTRING
;; ON-DISK), but CMUCL barfs on that.
- on-disk
- *package*)
+ on-disk
+ *package*)
(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)))
- (cdr in-memory))
- (if error-p (error 'missing-component :requires name))))))
+ (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
+ (cdr in-memory))
+ (if error-p (error 'missing-component :requires name))))))
(defun register-system (name system)
(format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
(setf (gethash (coerce-name name) *defined-systems*)
- (cons (get-universal-time) system)))
+ (cons (get-universal-time) system)))
(defun system-registered-p (name)
(gethash (coerce-name name) *defined-systems*))
@@ -419,8 +425,8 @@
(defmethod find-component ((module module) name &optional version)
(if (slot-boundp module 'components)
(let ((m (find name (module-components module)
- :test #'equal :key #'component-name)))
- (if (and m (version-satisfies m version)) m))))
+ :test #'equal :key #'component-name)))
+ (if (and m (version-satisfies m version)) m))))
;;; a component with no parent is a system
@@ -470,7 +476,7 @@
(defclass operation ()
((forced :initform nil :initarg :force :accessor operation-forced)
(original-initargs :initform nil :initarg :original-initargs
- :accessor operation-original-initargs)
+ :accessor operation-original-initargs)
(visited-nodes :initform nil :accessor operation-visited-nodes)
(visiting-nodes :initform nil :accessor operation-visiting-nodes)
(parent :initform nil :initarg :parent :accessor operation-parent)))
@@ -481,8 +487,8 @@
(prin1 (operation-original-initargs o) stream))))
(defmethod shared-initialize :after ((operation operation) slot-names
- &key force
- &allow-other-keys)
+ &key force
+ &allow-other-keys)
(declare (ignore slot-names force))
;; empty method to disable initarg validity checking
)
@@ -497,7 +503,9 @@
(cons (class-name (class-of o)) c))
(defgeneric operation-ancestor (operation)
- (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree"))
+ (:documentation
+ "Recursively chase the operation's parent pointer until we get to
+ the head of the tree"))
(defmethod operation-ancestor ((operation operation))
(aif (operation-parent operation)
@@ -507,22 +515,22 @@
(defun make-sub-operation (c o dep-c dep-o)
(let* ((args (copy-list (operation-original-initargs o)))
- (force-p (getf args :force)))
+ (force-p (getf args :force)))
;; note explicit comparison with T: any other non-NIL force value
;; (e.g. :recursive) will pass through
(cond ((and (null (component-parent c))
- (null (component-parent dep-c))
- (not (eql c dep-c)))
- (when (eql force-p t)
- (setf (getf args :force) nil))
- (apply #'make-instance dep-o
- :parent o
- :original-initargs args args))
- ((subtypep (type-of o) dep-o)
- o)
- (t
- (apply #'make-instance dep-o
- :parent o :original-initargs args args)))))
+ (null (component-parent dep-c))
+ (not (eql c dep-c)))
+ (when (eql force-p t)
+ (setf (getf args :force) nil))
+ (apply #'make-instance dep-o
+ :parent o
+ :original-initargs args args))
+ ((subtypep (type-of o) dep-o)
+ o)
+ (t
+ (apply #'make-instance dep-o
+ :parent o :original-initargs args args)))))
(defgeneric visit-component (operation component data))
@@ -530,14 +538,14 @@
(defmethod visit-component ((o operation) (c component) data)
(unless (component-visited-p o c)
(push (cons (node-for o c) data)
- (operation-visited-nodes (operation-ancestor o)))))
+ (operation-visited-nodes (operation-ancestor o)))))
(defgeneric component-visited-p (operation component))
(defmethod component-visited-p ((o operation) (c component))
(assoc (node-for o c)
- (operation-visited-nodes (operation-ancestor o))
- :test 'equal))
+ (operation-visited-nodes (operation-ancestor o))
+ :test 'equal))
(defgeneric (setf visiting-component) (new-value operation component))
@@ -547,18 +555,18 @@
(defmethod (setf visiting-component) (new-value (o operation) (c component))
(let ((node (node-for o c))
- (a (operation-ancestor o)))
+ (a (operation-ancestor o)))
(if new-value
- (pushnew node (operation-visiting-nodes a) :test 'equal)
- (setf (operation-visiting-nodes a)
- (remove node (operation-visiting-nodes a) :test 'equal)))))
+ (pushnew node (operation-visiting-nodes a) :test 'equal)
+ (setf (operation-visiting-nodes a)
+ (remove node (operation-visiting-nodes a) :test 'equal)))))
(defgeneric component-visiting-p (operation component))
(defmethod component-visiting-p ((o operation) (c component))
(let ((node (cons o c)))
(member node (operation-visiting-nodes (operation-ancestor o))
- :test 'equal)))
+ :test 'equal)))
(defgeneric component-depends-on (operation component)
(:documentation
@@ -582,28 +590,28 @@
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (class-name (class-of o))
- (slot-value c 'in-order-to))))
+ (slot-value c 'in-order-to))))
(defgeneric component-self-dependencies (operation component))
(defmethod component-self-dependencies ((o operation) (c component))
(let ((all-deps (component-depends-on o c)))
(remove-if-not (lambda (x)
- (member (component-name c) (cdr x) :test #'string=))
- all-deps)))
+ (member (component-name c) (cdr x) :test #'string=))
+ all-deps)))
(defmethod input-files ((operation operation) (c component))
(let ((parent (component-parent c))
- (self-deps (component-self-dependencies operation c)))
+ (self-deps (component-self-dependencies operation c)))
(if self-deps
- (mapcan (lambda (dep)
- (destructuring-bind (op name) dep
- (output-files (make-instance op)
- (find-component parent name))))
- self-deps)
- ;; no previous operations needed? I guess we work with the
- ;; original source file, then
- (list (component-pathname c)))))
+ (mapcan (lambda (dep)
+ (destructuring-bind (op name) dep
+ (output-files (make-instance op)
+ (find-component parent name))))
+ self-deps)
+ ;; no previous operations needed? I guess we work with the
+ ;; original source file, then
+ (list (component-pathname c)))))
(defmethod input-files ((operation operation) (c module)) nil)
@@ -674,66 +682,66 @@
(lambda (s)
(format s "~@<Retry loading component ~S.~@:>"
required-c))))))
- (do-dep (op dep)
- (cond ((eq op 'feature)
- (or (member (car dep) *features*)
- (error 'missing-dependency :required-by c
- :requires (car dep) :version nil)))
- (t
- (dolist (d dep)
+ (do-dep (op dep)
+ (cond ((eq op 'feature)
+ (or (member (car dep) *features*)
+ (error 'missing-dependency :required-by c
+ :requires (car dep) :version nil)))
+ (t
+ (dolist (d dep)
(cond ((consp d)
(assert (string-equal
(symbol-name (first d))
"VERSION"))
(appendf forced
- (do-one-dep op (second d) (third d))))
+ (do-one-dep op (second d) (third d))))
(t
(appendf forced (do-one-dep op d nil)))))))))
(aif (component-visited-p operation c)
- (return-from traverse
- (if (cdr it) (list (cons 'pruned-op c)) nil)))
+ (return-from traverse
+ (if (cdr it) (list (cons 'pruned-op c)) nil)))
;; dependencies
(if (component-visiting-p operation c)
- (error 'circular-dependency :components (list c)))
+ (error 'circular-dependency :components (list c)))
(setf (visiting-component operation c) t)
(loop for (required-op . deps) in (component-depends-on operation c)
- do (do-dep required-op deps))
+ do (do-dep required-op deps))
;; constituent bits
(let ((module-ops
- (when (typep c 'module)
- (let ((at-least-one nil)
- (forced nil)
- (error nil))
- (loop for kid in (module-components c)
- do (handler-case
- (appendf forced (traverse operation kid ))
- (missing-dependency (condition)
- (if (eq (module-if-component-dep-fails c) :fail)
- (error condition))
- (setf error condition))
- (:no-error (c)
- (declare (ignore c))
- (setf at-least-one t))))
- (when (and (eq (module-if-component-dep-fails c) :try-next)
- (not at-least-one))
- (error error))
- forced))))
- ;; now the thing itself
- (when (or forced module-ops
- (not (operation-done-p operation c))
- (let ((f (operation-forced (operation-ancestor operation))))
- (and f (or (not (consp f))
- (member (component-name
- (operation-ancestor operation))
- (mapcar #'coerce-name f)
- :test #'string=)))))
- (let ((do-first (cdr (assoc (class-name (class-of operation))
- (slot-value c 'do-first)))))
- (loop for (required-op . deps) in do-first
- do (do-dep required-op deps)))
- (setf forced (append (delete 'pruned-op forced :key #'car)
- (delete 'pruned-op module-ops :key #'car)
- (list (cons operation c))))))
+ (when (typep c 'module)
+ (let ((at-least-one nil)
+ (forced nil)
+ (error nil))
+ (loop for kid in (module-components c)
+ do (handler-case
+ (appendf forced (traverse operation kid ))
+ (missing-dependency (condition)
+ (if (eq (module-if-component-dep-fails c) :fail)
+ (error condition))
+ (setf error condition))
+ (:no-error (c)
+ (declare (ignore c))
+ (setf at-least-one t))))
+ (when (and (eq (module-if-component-dep-fails c) :try-next)
+ (not at-least-one))
+ (error error))
+ forced))))
+ ;; now the thing itself
+ (when (or forced module-ops
+ (not (operation-done-p operation c))
+ (let ((f (operation-forced (operation-ancestor operation))))
+ (and f (or (not (consp f))
+ (member (component-name
+ (operation-ancestor operation))
+ (mapcar #'coerce-name f)
+ :test #'string=)))))
+ (let ((do-first (cdr (assoc (class-name (class-of operation))
+ (slot-value c 'do-first)))))
+ (loop for (required-op . deps) in do-first
+ do (do-dep required-op deps)))
+ (setf forced (append (delete 'pruned-op forced :key #'car)
+ (delete 'pruned-op module-ops :key #'car)
+ (list (cons operation c))))))
(setf (visiting-component operation c) nil)
(visit-component operation c (and forced t))
forced)))
@@ -753,18 +761,19 @@
;;; compile-op
(defclass compile-op (operation)
- ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
+ ((proclamations :initarg :proclamations :accessor compile-op-proclamations
+ :initform nil)
(on-warnings :initarg :on-warnings :accessor operation-on-warnings
- :initform *compile-file-warnings-behaviour*)
+ :initform *compile-file-warnings-behaviour*)
(on-failure :initarg :on-failure :accessor operation-on-failure
- :initform *compile-file-failure-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))
- (get-universal-time))
+ (get-universal-time))
(load-preferences c operation))
;;; perform is required to check output-files to find out where to put
@@ -774,8 +783,8 @@
(let ((source-file (component-pathname 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)
@@ -853,8 +862,8 @@
(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)))
+ (> (file-write-date (component-pathname c))
+ (component-property c 'last-loaded-as-source)))
nil t))
(defclass test-op (operation) ())
@@ -863,10 +872,15 @@
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."))
+ (: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."))
+ (: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
@@ -877,10 +891,10 @@
(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))
+ (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))
@@ -889,49 +903,49 @@
(defmethod preference-file-for-system/operation ((s system) (operation t))
(let ((*default-pathname-defaults*
- (make-pathname :name nil :type nil
- :defaults *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"))
+ :type "lisp"
+ :directory '(:relative ".asdf"))
(truename (user-homedir-pathname)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
(defun operate (operation-class system &rest args &key (verbose t) version
- &allow-other-keys)
+ &allow-other-keys)
(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))))
+ :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 ~
+ (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)))))))))
+ op component))
+ (setf (gethash (type-of op)
+ (component-operation-times component))
+ (get-universal-time))
+ (return)))))))))
(defun oos (&rest args)
"Alias of OPERATE function"
@@ -942,41 +956,42 @@
(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))))))))
+ (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)))
(defmacro defsystem (name &body options)
(destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
(let ((component-options (remove-keyword :class options)))
`(progn
- ;; 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
- #+clisp
- (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
- #-clisp
- (change-class (cdr s) ',class))
- (t
- (register-system (quote ,name)
- (make-instance ',class :name ',name)))))
- (parse-component-form nil (apply
- #'list
- :module (coerce-name ',name)
- :pathname
- (or ,pathname
- (when *load-truename*
- (pathname-sans-name+type
- (resolve-symlinks *load-truename*)))
- *default-pathname-defaults*)
- ',component-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
+ #+clisp
+ (sysdef-error "Cannot redefine the existing system ~A with ~
+ a different class" s)
+ #-clisp
+ (change-class (cdr s) ',class))
+ (t
+ (register-system (quote ,name)
+ (make-instance ',class :name ',name)))))
+ (parse-component-form nil (apply
+ #'list
+ :module (coerce-name ',name)
+ :pathname
+ (or ,pathname
+ (when *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*)
@@ -990,167 +1005,163 @@
(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 "~@<don't recognize component type ~A~@:>" type))))
+ (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))))
+ (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))))))
+ (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)))
+ 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)
(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 weakly-depends-on depends-on components in-order-to)
+ (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 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))))
+ (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)))))
+ '(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))))
+ (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)))
+ (setf depends-on
+ (concatenate 'list *serial-depends-on* depends-on)))
(apply #'reinitialize-instance
- ret
- :name (coerce-name name)
- :pathname pathname
- :parent parent
- other-args)
+ 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 (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))))
+ (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))))
(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))))
+ (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 check-component-input (type name weakly-depends-on depends-on components in-order-to)
+(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))
+ type name depends-on))
(unless (listp weakly-depends-on)
(sysdef-error-component ":weakly-depends-on must be a list."
- type name weakly-depends-on))
+ type name weakly-depends-on))
(unless (listp components)
(sysdef-error-component ":components must be NIL or a list of components."
- type name 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)))
+ 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))
+ "~&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)
- )
+ #+allegro (excl:pathname-resolve-symbolic-links path))
-;;; optional extras
+;;;; optional extras
;;; 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
-
(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
@@ -1181,15 +1192,15 @@
:shell-type "/bin/sh"
:output-stream *verbose-out*)
- #+clisp ;XXX not exactly *verbose-out*, I know
+ #+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)))
+ (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)
@@ -1238,10 +1249,10 @@
(defun module-provide-asdf (name)
(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))))
+ (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")))
@@ -1264,8 +1275,7 @@
*central-registry*)
(pushnew
- '(merge-pathnames ".sbcl/systems/"
- (user-homedir-pathname))
+ '(merge-pathnames ".sbcl/systems/" (user-homedir-pathname))
*central-registry*)
(pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)