Skip to content
Snippets Groups Projects
Commit 5c22c9e7 authored by Gary King's avatar Gary King
Browse files

Applied patch from Luis Oliveira to prevent unnecessary unreachable code...

Applied patch from Luis Oliveira to prevent unnecessary unreachable code warnings under SBCL when using the :pathname argument in defsystem.
parent 7f8f741d
No related branches found
No related tags found
No related merge requests found
;;; This is asdf: Another System Definition Facility. $Revision: 1.110 $ ;;; This is asdf: Another System Definition Facility. $Revision: 1.111 $
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>. But note first that the canonical ;;; <cclan-list@lists.sf.net>. But note first that the canonical
...@@ -115,7 +115,7 @@ ...@@ -115,7 +115,7 @@
(in-package #:asdf) (in-package #:asdf)
(defvar *asdf-revision* (let* ((v "$Revision: 1.110 $") (defvar *asdf-revision* (let* ((v "$Revision: 1.111 $")
(colon (or (position #\: v) -1)) (colon (or (position #\: v) -1))
(dot (position #\. v))) (dot (position #\. v)))
(and v colon dot (and v colon dot
...@@ -971,33 +971,38 @@ method.") ...@@ -971,33 +971,38 @@ method.")
(aux key arglist))) (aux key arglist)))
(defmacro defsystem (name &body options) (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))) (let ((component-options (remove-keyword :class options)))
`(progn `(progn
;; system must be registered before we parse the body, otherwise ;; system must be registered before we parse the body, otherwise
;; we recur when trying to find an existing system of the same name ;; we recur when trying to find an existing system of the same name
;; to reuse options (e.g. pathname) from ;; to reuse options (e.g. pathname) from
(let ((s (system-registered-p ',name))) (let ((s (system-registered-p ',name)))
(cond ((and s (eq (type-of (cdr s)) ',class)) (cond ((and s (eq (type-of (cdr s)) ',class))
(setf (car s) (get-universal-time))) (setf (car s) (get-universal-time)))
(s (s
#+clisp #+clisp
(sysdef-error "Cannot redefine the existing system ~A with a different class" s) (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
#-clisp #-clisp
(change-class (cdr s) ',class)) (change-class (cdr s) ',class))
(t (t
(register-system (quote ,name) (register-system (quote ,name)
(make-instance ',class :name ',name))))) (make-instance ',class :name ',name)))))
(parse-component-form nil (apply (parse-component-form nil (apply
#'list #'list
:module (coerce-name ',name) :module (coerce-name ',name)
:pathname :pathname
(or ,pathname ;; to avoid a note about unreachable code
(when *load-truename* ,(if pathname-arg-p
(pathname-sans-name+type pathname
(resolve-symlinks *load-truename*))) `(or (when *load-truename*
*default-pathname-defaults*) (pathname-sans-name+type
',component-options)))))) (resolve-symlinks
*load-truename*)))
*default-pathname-defaults*))
',component-options))))))
(defun class-for-type (parent type) (defun class-for-type (parent type)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment