-;;; This is asdf: Another System Definition Facility. 1.96
+;;; This is asdf: Another System Definition Facility. 1.115
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>. But note first that the canonical
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'
-;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2007 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
#:system-author
#:system-maintainer
#:system-license
+ #:system-licence
+ #:system-source-file
+ #:system-relative-pathname
#:operation-on-warnings
#:operation-on-failure
#: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")
+#+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 "1.96")
+(defvar *asdf-revision* (let* ((v "1.115")
(colon (or (position #\: v) -1))
(dot (position #\. v)))
(and v colon dot
(list (parse-integer v :start (1+ colon)
- :junk-allowed t)
+ :junk-allowed t)
(parse-integer v :start (1+ dot)
- :junk-allowed t)))))
+ :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
(make-pathname :name nil :type nil :defaults pathname))
(define-modify-macro appendf (&rest args)
- append "Append onto list")
+ append "Append onto list")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; classes, condiitons
"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
+ ;; XXX crap name
(do-first :initform nil :initarg :do-first)
;; methods defined using the "inline" style inside a defsystem form:
;; need to store them somewhere so we can delete them when the system
:accessor system-long-description :initarg :long-description)
(author :accessor system-author :initarg :author)
(maintainer :accessor system-maintainer :initarg :maintainer)
- (licence :accessor system-licence :initarg :licence)))
+ (licence :accessor system-licence :initarg :licence
+ :accessor system-license :initarg :license)))
;;; version-satisfies
(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))
(defvar *defined-systems* (make-hash-table :test 'equal))
(defun coerce-name (name)
- (typecase name
- (component (component-name name))
- (symbol (string-downcase (symbol-name name)))
- (string name)
- (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+ (typecase name
+ (component (component-name name))
+ (symbol (string-downcase (symbol-name name)))
+ (string name)
+ (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-
(defun make-temporary-package ()
(flet ((try (counter)
(ignore-errors
- (make-package (format nil "ASDF~D" counter)
- :use '(:cl :asdf)))))
+ (make-package (format nil "ASDF~D" counter)
+ :use '(:cl :asdf)))))
(do* ((counter 0 (+ counter 1))
(package (try counter) (try counter)))
(package package))))
(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)
(member node (operation-visiting-nodes (operation-ancestor o))
:test 'equal)))
-(defgeneric component-depends-on (operation component))
+(defgeneric component-depends-on (operation component)
+ (:documentation
+ "Returns a list of dependencies needed by the component to perform
+ the operation. A dependency has one of the following forms:
+
+ (<operation> <component>*), where <operation> is a class
+ designator and each <component> is a component
+ designator, which means that the component depends on
+ <operation> having been performed on each <component>; or
+
+ (FEATURE <feature>), which means that the component depends
+ on <feature>'s presence in *FEATURES*.
+
+ Methods specialized on subclasses of existing component types
+ should usually append the results of CALL-NEXT-METHOD to the
+ list."))
+
+(defmethod component-depends-on ((op-spec symbol) (c component))
+ (component-depends-on (make-instance op-spec) c))
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (class-name (class-of o))
;; in-order-to slot with canonicalized
;; names instead of coercing this late
(coerce-name required-c) required-v)
- (error 'missing-dependency :required-by c
+ (error 'missing-dependency
+ :required-by c
:version required-v
:requires required-c)))
(op (make-sub-operation c operation dep-c required-op)))
(do-dep (op dep)
(cond ((eq op 'feature)
(or (member (car dep) *features*)
- (error 'missing-dependency :required-by c
- :requires (car dep) :version nil)))
+ (error 'missing-dependency
+ :required-by c
+ :requires (car dep)
+ :version nil)))
(t
(dolist (d dep)
(cond ((consp d)
(defmethod perform :after ((operation operation) (c component))
(setf (gethash (type-of operation) (component-operation-times c))
- (get-universal-time)))
+ (get-universal-time))
+ (load-preferences c operation))
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(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)
- ;(declare (ignore output))
+ (compile-file source-file :output-file output-file)
(when warnings-p
(case (operation-on-warnings operation)
(:warn (warn
(defmethod output-files ((operation compile-op) (c static-file))
nil)
+(defmethod input-files ((op compile-op) (c static-file))
+ nil)
+
+
;;; load-op
-(defclass load-op (operation) ())
+(defclass basic-load-op (operation) ())
+
+(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
(mapcar #'load (input-files o c)))
;;; load-source-op
-(defclass load-source-op (operation) ())
+(defclass load-source-op (basic-load-op) ())
(defmethod perform ((o load-source-op) (c cl-source-file))
(let ((source (component-pathname c)))
(defmethod perform ((operation test-op) (c component))
nil)
+(defgeneric load-preferences (system operation)
+ (:documentation
+ "Called to load system preferences after <perform operation
+system>. Typical uses are to set parameters that don't exist until
+after the system has been loaded."))
+
+(defgeneric preference-file-for-system/operation (system operation)
+ (:documentation
+ "Returns the pathname of the preference file for this system.
+Called by 'load-preferences to determine what file to load."))
+
+(defmethod load-preferences ((s t) (operation t))
+ ;; do nothing
+ (values))
+
+(defmethod load-preferences ((s system) (operation basic-load-op))
+ (let* ((*package* (find-package :common-lisp))
+ (file (probe-file (preference-file-for-system/operation s operation))))
+ (when file
+ (when *verbose-out*
+ (format *verbose-out*
+ "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
+ (component-name s)
+ (type-of operation) file))
+ (load file))))
+
+(defmethod preference-file-for-system/operation ((system t) (operation t))
+ ;; cope with anything other than systems
+ (preference-file-for-system/operation (find-system system t) operation))
+
+(defmethod preference-file-for-system/operation ((s system) (operation t))
+ (let ((*default-pathname-defaults*
+ (make-pathname :name nil :type nil
+ :defaults *default-pathname-defaults*)))
+ (merge-pathnames
+ (make-pathname :name (component-name s)
+ :type "lisp"
+ :directory '(:relative ".asdf"))
+ (truename (user-homedir-pathname)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
-(defun operate (operation-class system &rest args)
+(defvar *operate-docstring*
+ "Operate does three things:
+
+1. It creates an instance of `operation-class` using any keyword parameters
+as initargs.
+2. It finds the asdf-system specified by `system` (possibly loading
+it from disk).
+3. It then calls `traverse` with the operation and system as arguments
+
+The traverse operation is wrapped in `with-compilation-unit` and error
+handling code. If a `version` argument is supplied, then operate also
+ensures that the system found satisfies it using the `version-satisfies`
+method.")
+
+(defun operate (operation-class system &rest args &key (verbose t) version
+ &allow-other-keys)
(let* ((op (apply #'make-instance operation-class
- :original-initargs args args))
- (*verbose-out*
- (if (getf args :verbose t)
- *trace-output*
- (make-broadcast-stream)))
- (system (if (typep system 'component) system (find-system system)))
- (steps (traverse op system)))
- (with-compilation-unit ()
- (loop for (op . component) in steps do
- (loop
- (restart-case
- (progn (perform op component)
- (return))
- (retry ()
- :report
- (lambda (s)
- (format s "~@<Retry performing ~S on ~S.~@:>"
- op component)))
- (accept ()
- :report
- (lambda (s)
- (format s
- "~@<Continue, treating ~S on ~S as ~
- having been successful.~@:>"
- op component))
- (setf (gethash (type-of op)
- (component-operation-times component))
- (get-universal-time))
- (return))))))))
-
-(defun oos (&rest args)
- "Alias of OPERATE function"
- (apply #'operate args))
+ :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)))))))))
+
+(setf (documentation 'operate 'function)
+ *operate-docstring*)
+
+(defun oos (operation-class system &rest args &key force (verbose t) version)
+ (declare (ignore force verbose version))
+ (apply #'operate operation-class system args))
+
+(setf (documentation 'oos 'function)
+ (format nil
+ "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
+ *operate-docstring*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax
(aux key arglist)))
(defmacro defsystem (name &body options)
- (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
+ (destructuring-bind (&key (pathname nil pathname-arg-p) (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
- (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
+ ;; to avoid a note about unreachable code
+ ,(if pathname-arg-p
+ pathname
+ `(or (when *load-truename*
+ (pathname-sans-name+type
+ (resolve-symlinks
+ *load-truename*)))
+ *default-pathname-defaults*))
+ ',component-options))))))
(defun class-for-type (parent type)
- (let ((class
- (find-class
- (or (find-symbol (symbol-name type) *package*)
- (find-symbol (symbol-name type) #.(package-name *package*)))
- nil)))
+ (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
+ (find-symbol (symbol-name type)
+ (load-time-value
+ (package-name :asdf)))))
+ (class (dolist (symbol (if (keywordp type)
+ extra-symbols
+ (cons type extra-symbols)))
+ (when (and symbol
+ (find-class symbol nil)
+ (subtypep symbol 'component))
+ (return (find-class symbol))))))
(or class
(and (eq type :file)
(or (module-default-component-class parent)
(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
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))))
+ (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
(when (boundp '*serial-depends-on*)
(setf depends-on
(concatenate 'list *serial-depends-on* depends-on)))
- (apply #'reinitialize-instance
- ret
+ (apply #'reinitialize-instance ret
:name (coerce-name name)
:pathname pathname
:parent parent
name-hash)
(error 'duplicate-names
:name (component-name c))
- (setf (gethash (component-name c)
- name-hash)
- t)))))
+ (setf (gethash (component-name c)
+ name-hash)
+ t)))))
(setf (slot-value ret 'in-order-to)
(union-of-dependencies
(load-op (load-op ,@depends-on))))
(slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
- (loop for (n v) in `((perform ,perform) (explain ,explain)
- (output-files ,output-files)
- (operation-done-p ,operation-done-p))
- do (map 'nil
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf n
- ;; But this is hardly performance-critical
- (lambda (m) (remove-method (symbol-function n) m))
- (component-inline-methods ret))
- when v
- do (destructuring-bind (op qual (o c) &body body) v
- (pushnew
- (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
- ,@body))
- (component-inline-methods ret))))
+ (%remove-component-inline-methods ret rest)
+
ret)))
+(defun %remove-component-inline-methods (ret rest)
+ (loop for name in +asdf-methods+
+ do (map 'nil
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf n
+ ;; But this is hardly performance-critical
+ (lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods ret)))
+ ;; clear methods, then add the new ones
+ (setf (component-inline-methods ret) nil)
+ (loop for name in +asdf-methods+
+ for v = (getf rest (intern (symbol-name name) :keyword))
+ when v do
+ (destructuring-bind (op qual (o c) &body body) v
+ (pushnew
+ (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+ ,@body))
+ (component-inline-methods ret)))))
+
(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
"A partial test of the values of a component."
(when weakly-depends-on (warn "We got one! XXXXX"))
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
: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
(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*)
t))))
(defun contrib-sysdef-search (system)
- (let* ((name (coerce-name system))
- (home (truename (sb-ext:posix-getenv "SBCL_HOME")))
- (contrib (merge-pathnames
- (make-pathname :directory `(:relative ,name)
- :name name
- :type "asd"
- :case :local
- :version :newest)
- home)))
- (probe-file contrib)))
+ (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+ (when (and home (not (string= home "")))
+ (let* ((name (coerce-name system))
+ (home (truename home))
+ (contrib (merge-pathnames
+ (make-pathname :directory `(:relative ,name)
+ :name name
+ :type "asd"
+ :case :local
+ :version :newest)
+ home)))
+ (probe-file contrib)))))
(pushnew
- '(merge-pathnames "site-systems/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
+ '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+ (when (and home (not (string= home "")))
+ (merge-pathnames "site-systems/" (truename home))))
*central-registry*)
(pushnew
projects / sbcl.git / blobdiff