Skip to content
Snippets Groups Projects
Commit eb118038 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Create packages in a way that is more compatible with hot-upgrade.

Bug noticed by Tobias C. Rittweiler
when upgrading from ECL's ASDF 1.604 to the latest 1.622 or such.
parent b180658c
No related branches found
No related tags found
No related merge requests found
......@@ -53,146 +53,178 @@
#+ecl (require 'cmp)
(defpackage #:asdf-utilities
(:nicknames :asdf-extensions)
(:use #:common-lisp)
(:export
#:absolute-pathname-p
#:aif
#:appendf
#:asdf-message
#:coerce-name
#:directory-pathname-p
#:ends-with
#:ensure-directory-pathname
#:getenv
#:get-uid
#:length=n-p
#:make-collector
#:pathname-directory-pathname
#:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname
#:read-file-forms
#:remove-keys
#:remove-keyword
#:resolve-symlinks
#:split
#:component-name-to-pathname-components
#:system-registered-p
#:truenamize))
;;;; -------------------------------------------------------------------------
;;;; Cleanups in case of hot-upgrade.
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; Create packages in a way that is compatible with hot-upgrade.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; These must come *before* the defpackage form.
;;;; See more at the end of the file.
(eval-when (:compile-toplevel :load-toplevel :execute)
(block nil
(let ((asdf (or (find-package :asdf) (return))))
(flet ((frob (name)
(let ((sym (find-symbol (string name) asdf)))
(when sym
(unexport sym asdf)
(unintern sym asdf)))))
(frob '#:*asdf-revision*)
(do-external-symbols (sym (or (find-package :asdf-utilities) (return)))
(unless (eq sym (find-symbol (string sym) asdf))
(frob sym)))))))
(defpackage #:asdf
(:documentation "Another System Definition Facility")
(:use :common-lisp :asdf-utilities)
(:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
#:compile-system #:load-system #:test-system
#:compile-op #:load-op #:load-source-op
#: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
#:map-systems
#:operation-on-warnings
#:operation-on-failure
(eval-when (:load-toplevel :compile-toplevel :execute)
(labels ((rename-away (package)
(loop :with name = (package-name package)
:for i :from 1 :for n = (format nil "~A.~D" name i)
:unless (find-package n) :do (rename-package package name)))
(ensure-exists (name nicknames)
(let* ((previous
(remove-duplicates
(remove-if
#'null
(mapcar #'find-package (cons name nicknames)))
:from-end t)))
(cond
(previous
(map () #'rename-away (cdr previous))
(rename-package (car previous) name nicknames)
(car previous))
(t
(make-package name :nicknames nicknames)))))
(remove-symbol (symbol package)
(let ((sym (find-symbol (string symbol) package)))
(when sym
(unexport sym package)
(unintern sym package))))
(ensure-unintern (package symbols)
(dolist (sym symbols) (remove-symbol sym package)))
(ensure-use (package use)
(dolist (used use)
(do-external-symbols (sym used)
(unless (eq sym (find-symbol (string sym) package))
(remove-symbol sym package)))
(use-package used package)))
(ensure-export (package export)
(let ((syms (loop :for x :in export :collect
(intern (string x) package))))
(do-external-symbols (sym package)
(unless (member sym syms)
(remove-symbol sym package)))
(dolist (sym syms)
(export sym package))))
(ensure-package (name &key nicknames use export unintern)
(let* ((p (ensure-exists name nicknames)))
(ensure-use p use)
(ensure-unintern p unintern)
(ensure-export p export)
p)))
(ensure-package
':asdf-utilities
:nicknames '(#:asdf-extensions)
:use '(#:common-lisp)
:export
'(#:absolute-pathname-p
#:aif
#:appendf
#:asdf-message
#:coerce-name
#:directory-pathname-p
#:ends-with
#:ensure-directory-pathname
#:getenv
#:get-uid
#:length=n-p
#:make-collector
#:pathname-directory-pathname
#:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname
#:read-file-forms
#:remove-keys
#:remove-keyword
#:resolve-symlinks
#:split
#:component-name-to-pathname-components
#:system-registered-p
#:truenamize))
(ensure-package
':asdf
:use '(:common-lisp :asdf-utilities)
:unintern '(#:*asdf-revision*)
:export
'(#:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
#:compile-system #:load-system #:test-system
#:compile-op #:load-op #:load-source-op
#: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
#:map-systems
#:operation-on-warnings
#:operation-on-failure
;#:*component-parent-pathname*
#:*system-definition-search-functions*
#:*central-registry* ; variables
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*resolve-symlinks*
#:asdf-version
#:operation-error #:compile-failed #:compile-warned #:compile-error
#:error-name
#:error-pathname
#:missing-definition
#:error-component #:error-operation
#:system-definition-error
#:missing-component
#:missing-component-of-version
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency ; errors
#:duplicate-names
#:try-recompiling
#:retry
#:accept ; restarts
#:coerce-entry-to-directory
#:remove-entry-from-registry
#:standard-asdf-method-combination
#:around ; protocol assistants
#:initialize-output-translations
#:clear-output-translations
#:ensure-output-translations
#:apply-output-translations
#:compile-file-pathname*
#:*default-source-registries*
#:initialize-source-registry
#:compute-source-registry
#:clear-source-registry
#:ensure-source-registry
#:process-source-registry))
#:*system-definition-search-functions*
#:*central-registry* ; variables
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*resolve-symlinks*
#:asdf-version
#:operation-error #:compile-failed #:compile-warned #:compile-error
#:error-name
#:error-pathname
#:missing-definition
#:error-component #:error-operation
#:system-definition-error
#:missing-component
#:missing-component-of-version
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency ; errors
#:duplicate-names
#:try-recompiling
#:retry
#:accept ; restarts
#:coerce-entry-to-directory
#:remove-entry-from-registry
#:standard-asdf-method-combination
#:around ; protocol assistants
#:initialize-output-translations
#:clear-output-translations
#:ensure-output-translations
#:apply-output-translations
#:compile-file-pathname*
#:*default-source-registries*
#:initialize-source-registry
#:compute-source-registry
#:clear-source-registry
#:ensure-source-registry
#:process-source-registry))))
#+nil
(error "The author of this file habitually uses #+nil to comment out ~
......
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