Commit 6cb345b9 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.69: Victory! test-upgrade now works with CCL and SBCL.

Had to fix a few more issues in package update,
add support for frobbing CCL setf function names,
and fix upgrade detection for the new package world.
parent b6d6fb06
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.68" ;; to be automatically updated by bin/bump-revision :version "2.26.69" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components :components
((:file "asdf"))) ((:file "asdf")))
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.68: Another System Definition Facility. ;;; This is ASDF 2.26.69: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -75,6 +75,53 @@ when the symbol is not found." ...@@ -75,6 +75,53 @@ when the symbol is not found."
(error (error "symbol ~A not present in package ~A" (error (error "symbol ~A not present in package ~A"
(string symbol) (package-name package)))))) (string symbol) (package-name package))))))
(values nil nil)))) (values nil nil))))
(defun symbol-shadowing-p (symbol package)
(member symbol (package-shadowing-symbols package)))
(defun rehome-symbol (symbol package-designator)
"Changes the home package of a symbol, also leaving it present in its old home if any"
(let* ((name (symbol-name symbol))
(package (find-package* package-designator))
(old-package (symbol-package symbol))
(old-status (and old-package (nth-value 1 (find-symbol name old-package))))
(shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
(multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
(unless (eq package old-package)
(let ((overwritten-symbol-shadowing-p
(and overwritten-symbol-status
(symbol-shadowing-p overwritten-symbol package))))
(when old-package
(if shadowing
(shadowing-import shadowing old-package))
(unintern symbol old-package))
(cond
(overwritten-symbol-shadowing-p
(shadowing-import symbol package))
(t
(when overwritten-symbol-status
(unintern overwritten-symbol package))
(import symbol package)))
(if shadowing
(shadowing-import symbol old-package)
(import symbol old-package))
#+ccl
(multiple-value-bind (setf-name foundp)
(gethash symbol ccl::%setf-function-names%)
(when foundp
(let* ((setf-function (fdefinition setf-name))
(new-setf-name (ccl::construct-setf-function-name symbol)))
(setf (fdefinition new-setf-name) setf-function
(gethash symbol ccl::%setf-function-names%) new-setf-name
(gethash new-setf-name ccl::%setf-function-name-inverses%) symbol))))
#+ccl
(multiple-value-bind (overwritten-setf foundp)
(gethash overwritten-symbol ccl::%setf-function-names%)
(when foundp
(unintern overwritten-setf)))
(when (eq old-status :external)
(export symbol old-package))
(when (eq overwritten-symbol-status :external)
(export symbol package))))
(values overwritten-symbol overwritten-symbol-status))))
(defun symbol-name-package (symbol) (defun symbol-name-package (symbol)
(cons (symbol-name symbol) (package-name (symbol-package symbol)))) (cons (symbol-name symbol) (package-name (symbol-package symbol))))
(defun package-names (package) (defun package-names (package)
...@@ -125,6 +172,8 @@ when the symbol is not found." ...@@ -125,6 +172,8 @@ when the symbol is not found."
(loop :for name :in symbols (loop :for name :in symbols
:for sym = (find-symbol* name package nil) :for sym = (find-symbol* name package nil)
:when sym :do #-gcl (fmakunbound `(setf ,sym)))) :when sym :do #-gcl (fmakunbound `(setf ,sym))))
(defun packages-from-names (names)
(remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
(defun ensure-package (name &key (defun ensure-package (name &key
upgrade upgrade
nicknames documentation use nicknames documentation use
...@@ -132,29 +181,17 @@ when the symbol is not found." ...@@ -132,29 +181,17 @@ when the symbol is not found."
import-from export intern import-from export intern
recycle mix reexport recycle mix reexport
unintern fmakunbound fmakunbound-setf) unintern fmakunbound fmakunbound-setf)
(DBG :ensure-package name nicknames upgrade documentation use (let* ((name (string name))
shadow shadowing-import-from
import-from export intern
recycle mix reexport
unintern fmakunbound fmakunbound-setf)
(let* ((nicknames (mapcar #'string nicknames))
(shadow (mapcar #'string shadow))
(shadowing-import-from (loop :for sif :in shadowing-import-from
:collect (mapcar #'string sif)))
(import-from (loop :for if :in import-from
:collect (mapcar #'string if)))
(export (mapcar #'string export))
(recycle (remove nil (mapcar #'find-package recycle)))
(shadowed (make-hash-table :test 'equal)) ; string to bool
(imported (make-hash-table :test 'equal)) ; string to bool
(exported (make-hash-table :test 'equal)) ; string to bool
(inherited (make-hash-table :test 'equal)) ; string to package name
(name (string name))
(nicknames (mapcar #'string nicknames)) (nicknames (mapcar #'string nicknames))
(names (cons name nicknames)) (names (cons name nicknames))
(previous (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t)) (previous (packages-from-names names))
(discarded (cdr previous)) (discarded (cdr previous))
(package (DBG :xxx names previous discarded (or (first previous) (make-package name :nicknames nicknames))))) (package (or (first previous) (make-package name :nicknames nicknames)))
(recycle (packages-from-names recycle))
(shadowed (make-hash-table :test 'equal)) ; string to bool
(imported (make-hash-table :test 'equal)) ; string to bool
(exported (make-hash-table :test 'equal)) ; string to bool
(inherited (make-hash-table :test 'equal))) ; string to package name
(labels (labels
((ensure-shadowing-import (sym p) ((ensure-shadowing-import (sym p)
(let* ((name (string sym)) (let* ((name (string sym))
...@@ -166,7 +203,7 @@ when the symbol is not found." ...@@ -166,7 +203,7 @@ when the symbol is not found."
(t (t
(setf (gethash name shadowed) t) (setf (gethash name shadowed) t)
(setf (gethash name imported) t) (setf (gethash name imported) t)
(shadowing-import package))))) (shadowing-import i package)))))
(ensure-import (sym p) (ensure-import (sym p)
(let* ((name (string sym)) (let* ((name (string sym))
(i (find-symbol* name p))) (i (find-symbol* name p)))
...@@ -218,12 +255,12 @@ when the symbol is not found." ...@@ -218,12 +255,12 @@ when the symbol is not found."
(when xp (when xp
(unintern* x package))))))) (unintern* x package)))))))
(recycle-symbol (name) (recycle-symbol (name)
(loop :for r :in recycle (dolist (r recycle (values nil nil))
:for s = (find-symbol* name r nil) (multiple-value-bind (symbol status) (find-symbol name r)
:when s :do (return (values s r)))) (when (and status (eq r (symbol-package symbol)))
(return (values symbol r))))))
(symbol-recycled-p (sym) (symbol-recycled-p (sym)
(loop :for r :in recycle (member (symbol-package sym) recycle))
:thereis (multiple-value-bind (s sp) (find-symbol* sym r nil) (and sp (eq sym s)))))
(ensure-symbol (name &optional intern) (ensure-symbol (name &optional intern)
(unless (or (gethash name shadowed) (unless (or (gethash name shadowed)
(gethash name imported) (gethash name imported)
...@@ -233,7 +270,7 @@ when the symbol is not found." ...@@ -233,7 +270,7 @@ when the symbol is not found."
((eq previous package)) ((eq previous package))
((or (not previous) (not (member (symbol-package recycled) recycle))) ((or (not previous) (not (member (symbol-package recycled) recycle)))
(when intern (intern* name package))) (when intern (intern* name package)))
(t (unintern* name package nil) (unintern* recycled previous) (import recycled package)))))) (t (rehome-symbol recycled package))))))
(ensure-export (name p) (ensure-export (name p)
(multiple-value-bind (symbol status) (find-symbol name p) (multiple-value-bind (symbol status) (find-symbol name p)
(assert status) (assert status)
...@@ -258,34 +295,24 @@ when the symbol is not found." ...@@ -258,34 +295,24 @@ when the symbol is not found."
(ensure-exported name sym u)))))))) (ensure-exported name sym u))))))))
(assert (soft-upgrade-p upgrade)) (assert (soft-upgrade-p upgrade))
(setf (documentation package t) documentation) (setf (documentation package t) documentation)
;;#+DBG (untrace)(trace find-symbol make-package delete-package use-package unuse-package import export intern shadow shadowing-import unintern unexport)
(DBG :names names package previous discarded (package-data package :name-package t))
(loop :for p :in discarded (loop :for p :in discarded
:for n = (remove-if #'(lambda (x) (member x names :test 'equal)) :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
(package-names p)) (package-names p))
:do (DBG :baz (package-names p) n)
:do (if n (rename-package discarded (first n) (rest n)) :do (if n (rename-package discarded (first n) (rest n))
(delete-package* discarded))) (delete-package* discarded)))
(rename-package package name nicknames) (rename-package package name nicknames)
(DBG :unuse)
(loop :for p :in (set-difference (package-use-list package) (append mix use)) (loop :for p :in (set-difference (package-use-list package) (append mix use))
:do (unuse-package p package)) :do (unuse-package p package))
(DBG :unintern)
(dolist (name unintern) (unintern* name package nil)) (dolist (name unintern) (unintern* name package nil))
(DBG :export?)
(loop :for sym :in export :for name = (string sym) :do (loop :for sym :in export :for name = (string sym) :do
(setf (gethash name exported) t)) (setf (gethash name exported) t))
(DBG :reexport)
(loop :for p :in reexport :do (loop :for p :in reexport :do
(do-external-symbols (sym p) (do-external-symbols (sym p)
(let ((name (string sym))) (let ((name (string sym)))
(export (find-symbol* name package) package) (setf (gethash name exported) t)))) (export (find-symbol* name package) package) (setf (gethash name exported) t))))
(DBG :unexport)
(do-external-symbols (sym package) (do-external-symbols (sym package)
(unless (gethash (symbol-name sym) exported) (unexport sym package))) (unless (gethash (symbol-name sym) exported) (unexport sym package)))
(DBG :shadow)
(loop :for s :in shadow :for name = (string s) :do (loop :for s :in shadow :for name = (string s) :do
(DBG :sha name)
(setf (gethash name shadowed) t) (setf (gethash name shadowed) t)
(multiple-value-bind (recycled previous) (recycle-symbol name) (multiple-value-bind (recycled previous) (recycle-symbol name)
(cond (cond
...@@ -294,36 +321,28 @@ when the symbol is not found." ...@@ -294,36 +321,28 @@ when the symbol is not found."
((nil :inherited) (shadow name package)) ((nil :inherited) (shadow name package))
((:internal :external) (shadowing-import (make-symbol name) package)))) ((:internal :external) (shadowing-import (make-symbol name) package))))
((eq previous package) (shadow recycled package)) ((eq previous package) (shadow recycled package))
(t (unintern* recycled previous) (shadowing-import recycled package))))) (t (rehome-symbol recycled package)))))
(loop :for (p . syms) :in shadowing-import-from :do (loop :for (p . syms) :in shadowing-import-from :do
(DBG :shaif p syms)
(dolist (sym syms) (ensure-shadowing-import sym p))) (dolist (sym syms) (ensure-shadowing-import sym p)))
(loop :for p :in mix :do (loop :for p :in mix :do
(DBG :mix p)
(do-external-symbols (sym p) (ensure-mix sym p))) (do-external-symbols (sym p) (ensure-mix sym p)))
(loop :for (p . syms) :in import-from :do (loop :for (p . syms) :in import-from :do
(DBG :if p syms)
(dolist (sym syms) (ensure-import sym p))) (dolist (sym syms) (ensure-import sym p)))
(loop :for p :in use :for sp = (string p) :for pp = (find-package sp) :do (loop :for p :in use :for sp = (string p) :for pp = (find-package sp) :do
(DBG :use p sp pp)
(do-external-symbols (sym pp) (ensure-inherited sym sp)) (do-external-symbols (sym pp) (ensure-inherited sym sp))
(use-package pp package)) (use-package pp package))
(DBG :intern)
(loop :for name :being :the :hash-keys :of exported :do (loop :for name :being :the :hash-keys :of exported :do
(ensure-symbol name t)) (ensure-symbol name t))
(dolist (name (append intern fmakunbound fmakunbound-setf)) (dolist (name (append intern fmakunbound fmakunbound-setf))
(ensure-symbol (string name) t)) (ensure-symbol (string name) t))
(DBG :cleanup)
(do-symbols (sym package) (do-symbols (sym package)
(ensure-symbol (symbol-name sym))) (ensure-symbol (symbol-name sym)))
(DBG :export)
(loop :for name :being :the :hash-keys :of exported :do (loop :for name :being :the :hash-keys :of exported :do
(ensure-export name package)) (ensure-export name package))
;; do away with packages with conflicting (nick)names ;; do away with packages with conflicting (nick)names
;; note from ASDF 2.26: ECL might not be liking an early fmakunbound (below #-ecl'ed) ;; note from ASDF 2.26: ECL might not be liking an early fmakunbound (below #-ecl'ed)
(ensure-package-fmakunbound package fmakunbound) (ensure-package-fmakunbound package fmakunbound)
(ensure-package-fmakunbound-setf package fmakunbound-setf) (ensure-package-fmakunbound-setf package fmakunbound-setf)
;;#+DBG (untrace)
package)))) package))))
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
......
...@@ -24,19 +24,18 @@ ...@@ -24,19 +24,18 @@
;; "2.345.6" would be a development version in the official upstream ;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.68") (asdf-version "2.26.69")
(existing-asdf (find-class 'component nil)) (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))) (already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there) (unless (and existing-asdf already-there)
(when (and existing-asdf *asdf-verbose*) (when existing-asdf
(format *trace-output* (asdf-message "~&; Upgrading ASDF ~@[from version ~A ~]to version ~A~%"
"~&; Upgrading ASDF ~@[from version ~A ~]to version ~A~%" existing-version asdf-version))
existing-version asdf-version)) (unless already-there
(setf *asdf-version* asdf-version (push existing-version *upgraded-p*))
*upgraded-p* (if existing-version (setf *asdf-version* asdf-version))))
(cons existing-version *upgraded-p*)
*upgraded-p*)))))
;;;; User interface ;;;; User interface
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment