From e9514f6e8101ce0bc7cd99cfeefa56c6f66a9136 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Wed, 9 Jan 2013 18:34:47 -0500 Subject: [PATCH] 2.26.66: Attempt for define-package to preserve export. --- Makefile | 2 +- action.lisp | 3 + asdf.asd | 2 +- backward-interface.lisp | 1 + bundle.lisp | 1 + component.lisp | 2 + configuration.lisp | 1 + find-component.lisp | 1 + header.lisp | 2 +- interface.lisp | 32 ++---- lisp-build.lisp | 1 + operate.lisp | 1 + output-translations.lisp | 2 + package.lisp | 187 ++++++++++++++++++++------------ pathname.lisp | 1 + plan.lisp | 1 + source-registry.lisp | 1 + system.lisp | 3 +- test/test-around-compile.script | 2 +- upgrade.lisp | 2 +- 20 files changed, 145 insertions(+), 103 deletions(-) diff --git a/Makefile b/Makefile index ba13d157..3f9e2f42 100644 --- a/Makefile +++ b/Makefile @@ -88,7 +88,7 @@ clean: mrproper: clean rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap -test-upgrade: +test-upgrade: tmp/asdf.lisp # 1.37 is the last release by Daniel Barlow # 1.97 is the last release before Gary King takes over # 1.369 is the last release by Gary King diff --git a/action.lisp b/action.lisp index 10fd3efa..0c85e733 100644 --- a/action.lisp +++ b/action.lisp @@ -6,6 +6,9 @@ (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/os :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation) #+gcl<2.7 (:shadowing-import-from :asdf/implementation #:type-of) + (:fmakunbound + #:explain #:output-files #:perform #:perform-with-restarts + #:operation-done-p #:compute-action-stamp #:component-depends-on #:mark-operation-done) (:export #:action #:explain #:operation-description diff --git a/asdf.asd b/asdf.asd index ca1ae6e9..fe330065 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.65" ;; to be automatically updated by bin/bump-revision + :version "2.26.66" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/backward-interface.lisp b/backward-interface.lisp index f17ebf56..3f76574d 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -3,6 +3,7 @@ (asdf/package:define-package :asdf/backward-interface (:recycle :asdf/backward-interface :asdf) + (:fmakunbound #:component-load-dependencies) (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/os :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-build :asdf/operate :asdf/output-translations) diff --git a/bundle.lisp b/bundle.lisp index a3fdc86d..1cd2cde8 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -2,6 +2,7 @@ ;;;; ASDF-Bundle (asdf/package:define-package :asdf/bundle + (:fmakunbound #:trivial-system-p) (:recycle :asdf/bundle :asdf) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/lisp-build :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation diff --git a/component.lisp b/component.lisp index 17177b0b..14ece715 100644 --- a/component.lisp +++ b/component.lisp @@ -3,7 +3,9 @@ (asdf/package:define-package :asdf/component (:recycle :asdf/component :asdf) + (:fmakunbound #:component-relative-pathname #:source-file-type) (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/upgrade) + (:intern #:documentation #:long-documentation) (:export #:component #:component-find-path #:component-name #:component-pathname #:component-relative-pathname diff --git a/configuration.lisp b/configuration.lisp index 119cec93..4407fe5a 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -3,6 +3,7 @@ (asdf/package:define-package :asdf/configuration (:recycle :asdf/configuration :asdf) + (:fmakunbound #:resolve-location) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os) (:export #:get-folder-path diff --git a/find-component.lisp b/find-component.lisp index 517bb03c..420417ff 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -3,6 +3,7 @@ (asdf/package:define-package :asdf/find-component (:recycle :asdf/find-component :asdf) + (:fmakunbound #:find-component) (:use :common-lisp :asdf/utility :asdf/os :asdf/component :asdf/system :asdf/find-system) (:export diff --git a/header.lisp b/header.lisp index 24e9d672..6eed10d0 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.65: Another System Definition Facility. +;;; This is ASDF 2.26.66: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/interface.lisp b/interface.lisp index e23f0ecc..7b0e7456 100644 --- a/interface.lisp +++ b/interface.lisp @@ -2,8 +2,14 @@ ;;;; Handle ASDF package upgrade, including implementation-dependent magic. (asdf/package:define-package :asdf/interface - (:recycle :asdf/interface :asdf) (:nicknames :asdf) + (:recycle :asdf/interface :asdf) + (:unintern + #:*asdf-revision* #:around #:asdf-method-combination + #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p + #:split #:make-collector + #:loaded-systems ; makes for annoying SLIME completion + #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function (:use :common-lisp :asdf/package :asdf/implementation :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component @@ -133,27 +139,3 @@ (with-upgrade (:when (fboundp 'make-sub-operation)) (defun* make-sub-operation (c o dep-c dep-o) (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) - -#| - (pkgdcl - :asdf - :use (:common-lisp) - :fmakunbound - (#:perform #:explain #:output-files #:operation-done-p #:traverse-action #:traverse - #:compute-action-stamp #:component-load-dependencies #:action-valid-p - #:component-depends-on #:perform-plan #:mark-operation-done #:operation-forced - #:perform-with-restarts #:component-relative-pathname - #:system-source-file #:operate #:find-system #:find-component #:find-operation - #:apply-output-translations #:translate-pathname* #:resolve-location - #:system-relative-pathname #:source-file-type #:builtin-system-p - #:inherit-source-registry #:process-source-registry #:process-source-registry-directive - #:compile-file* #:source-file-type #:trivial-system-p) - :fmakunbound-setf (#:output-translations) - :unintern - (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector - #:do-dep #:do-one-dep #:do-traverse #:visit-action #:component-visited-p - #+(or ecl mkcl) #:output-files #+ecl #:trivial-system-p - #:loaded-systems ; makes for annoying SLIME completion - #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function - :export -|# diff --git a/lisp-build.lisp b/lisp-build.lisp index 52f0baca..12d7a539 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -4,6 +4,7 @@ (asdf/package:define-package :asdf/lisp-build (:recycle :asdf/lisp-build :asdf) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os) + (:fmakunbound #:compile-file*) (:export #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*compile-file-function* #:compile-file* #:compile-file-pathname* diff --git a/operate.lisp b/operate.lisp index 343cf906..038742c8 100644 --- a/operate.lisp +++ b/operate.lisp @@ -3,6 +3,7 @@ (asdf/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) + (:fmakunbound #:operate) (:use :common-lisp :asdf/implementation :asdf/utility :asdf/upgrade :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-build :asdf/lisp-action #:asdf/plan diff --git a/output-translations.lisp b/output-translations.lisp index 06c464c1..e059809c 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -4,6 +4,8 @@ (asdf/package:define-package :asdf/output-translations (:recycle :asdf/output-translations :asdf) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/configuration :asdf/action) + (:fmakunbound #:apply-output-translations) + (:fmakunbound-setf #:output-translations) (:export #:invalid-output-translation #:output-translations #:output-translations-initialized-p diff --git a/package.lisp b/package.lisp index 8fa3ec13..5ab0aa37 100644 --- a/package.lisp +++ b/package.lisp @@ -13,8 +13,9 @@ (defpackage :asdf/package (:use :common-lisp) (:export - #:find-package* #:package-name* #:find-symbol* #:intern* #:unintern* - #:unlink-package #:ensure-package #:define-package #:package-data)) + #:find-package* #:find-symbol* #:intern* #:unintern* + #:symbol-name-package #:package-data + #:delete-package* #:ensure-package #:define-package)) (in-package :asdf/package) @@ -46,9 +47,6 @@ outputs a tag plus a list of variable and their values, returns the last value" (package package) (error (error "No package named ~S" (string package-designator))) (t nil)))) - (defun package-name* (package-designator &optional (error t)) - (let ((package (find-package* package-designator error))) - (when package (package-name package)))) (defun find-symbol* (name package-designator &optional (error t)) "Find a symbol in a package of given string'ified NAME; unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax @@ -65,7 +63,7 @@ when the symbol is not found." (error (error "There is no symbol ~S in package ~S" name (package-name package)))))) (values nil nil)))) (defun intern* (name package-designator &optional (error t)) - (intern (string name) (package-name* package-designator error))) + (intern (string name) (find-package* package-designator error))) (defun unintern* (name package-designator &optional (error t)) (block nil (let ((package (find-package* package-designator error))) @@ -77,13 +75,19 @@ when the symbol is not found." (error (error "symbol ~A not present in package ~A" (string symbol) (package-name package)))))) (values nil nil)))) - (defun package-data (package-designator &optional (error t)) + (defun symbol-name-package (symbol) + (cons (symbol-name symbol) (package-name (symbol-package symbol)))) + (defun package-names (package) + (cons (package-name package) (package-nicknames package))) + (defun package-data (package-designator &key name-package (error t)) (let ((package (find-package* package-designator error))) (when package - (labels ((string-sort (strings) - (sort strings #'string<)) + (labels ((marshall-symbols (symbols) + (if name-package (mapcar #'symbol-name-package symbols) symbols)) + (sort-symbols (symbols) + (marshall-symbols (sort symbols #'string<))) (sort-packages (packages) - (string-sort (mapcar #'package-name packages)))) + (sort (mapcar #'package-name packages) #'string<))) (loop :with internal :with external :with inherited :for sym :being :the :symbols :in package :for status = (nth-value 1 (find-symbol* sym package)) :do @@ -95,10 +99,10 @@ when the symbol is not found." (return `(:name ,(package-name package) :nicknames ,(package-nicknames package) - :internal ,(string-sort internal) - :external ,(string-sort external) - :inherited ,(string-sort inherited) - :shadowing ,(string-sort (package-shadowing-symbols package)) + :internal ,(sort-symbols internal) + :external ,(sort-symbols external) + :inherited ,(sort-symbols inherited) + :shadowing ,(sort-symbols (package-shadowing-symbols package)) :use ,(sort-packages (package-use-list package)) :used-by ,(sort-packages (package-used-by-list package)))))))))) @@ -108,7 +112,7 @@ when the symbol is not found." (defun ensure-package-unused (package) (loop :for p :in (package-used-by-list package) :do (unuse-package package p))) - (defun ensure-package-deleted (package) ;; &key upgrade + (defun delete-package* (package) (let ((p (find-package package))) (when p (ensure-package-unused p) @@ -121,10 +125,6 @@ when the symbol is not found." (loop :for name :in symbols :for sym = (find-symbol* name package nil) :when sym :do #-gcl (fmakunbound `(setf ,sym)))) - (defun recycle-symbol (name recycle) - (loop :for r :in recycle - :for s = (find-symbol* name r nil) - :when s :do (return (values s r)))) (defun ensure-package (name &key upgrade nicknames documentation use @@ -132,6 +132,11 @@ when the symbol is not found." import-from export intern recycle mix reexport unintern fmakunbound fmakunbound-setf) + (DBG :ensure-package name nicknames upgrade documentation use + 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 @@ -144,36 +149,11 @@ when the symbol is not found." (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 - (previous (remove-duplicates - (mapcar #'find-package (cons name nicknames)) - :from-end t)) + (names (cons name nicknames)) + (previous (DBG :p names (mapcar 'find-package names) (remove-duplicates (mapcar #'find-package names) :from-end t))) (discarded (cdr previous)) (package (or (first previous) (make-package name :nicknames nicknames)))) - (setf (documentation package t) documentation) - (DBG :ensure-package name upgrade - nicknames documentation use - shadow shadowing-import-from - import-from export intern - recycle mix reexport - unintern fmakunbound fmakunbound-setf) - ;;#+DBG (untrace)(trace find-symbol make-package delete-package use-package unuse-package import export intern shadow shadowing-import unintern unexport) - (assert (soft-upgrade-p upgrade)) - (ensure-package-unused package) - (map () #'ensure-package-deleted discarded) - (rename-package package name nicknames) - (dolist (name unintern) (unintern* name package)) - ;;; Compute the desired state of the package - (loop :for sym :in shadow :for name = (string sym) :do - (DBG :sha name) - (setf (gethash name shadowed) t) - (multiple-value-bind (recycled previous) (recycle-symbol name recycle) - (cond - ((or (not previous) (not (member (symbol-package recycle) recycle))) - (ecase (nth-value 1 (find-symbol* name package nil)) - ((nil :inherited) (shadow name package)) - ((:internal :external) (shadowing-import (make-symbol name) package)))) - ((eq previous package) (shadow recycled package)) - (t (unintern* recycled previous) (shadowing-import recycled package))))) + (DBG :foo) (labels ((ensure-shadowing-import (sym p) (let* ((name (string sym)) @@ -234,17 +214,84 @@ when the symbol is not found." (t (when xp (unintern* x package))))))) - (ensure-registered (sym) - (let ((name (string sym))) - (unless (or (gethash name shadowed) - (gethash name imported) - (gethash name inherited)) - (multiple-value-bind (recycled previous) (recycle-symbol name recycle) - (cond - ((or (not previous) (not (member (symbol-package recycled) recycle))) - (unintern* sym package)) - ((eq previous package)) - (t (unintern* recycled previous) (import recycled package)))))))) + (recycle-symbol (name) + (loop :for r :in recycle + :for s = (find-symbol* name r nil) + :when s :do (return (values s r)))) + (symbol-recycled-p (sym) + (loop :for r :in recycle + :thereis (multiple-value-bind (s sp) (find-symbol* sym r nil) (and sp (eq sym s))))) + (ensure-symbol (name &optional intern) + (unless (or (gethash name shadowed) + (gethash name imported) + (gethash name inherited)) + (multiple-value-bind (recycled previous) (recycle-symbol name) + (cond + ((eq previous package)) + ((or (not previous) (not (member (symbol-package recycled) recycle))) + (when intern (intern* name package))) + (t (unintern* name package) (unintern* recycled previous) (import recycled package)))))) + (ensure-export (name p) + (multiple-value-bind (symbol status) (find-symbol name p) + (assert status) + (unless (eq status :external) + (ensure-exported name symbol p)))) + (ensure-exported (name sym p) + (dolist (u (package-used-by-list p)) + (ensure-exported-to-user name sym u)) + (export sym p)) + (ensure-exported-to-user (name sym u) + (multiple-value-bind (usym ustat) (find-symbol name u) + (unless (eq sym usym) + (let ((shadowing (member usym (package-shadowing-symbols u)))) + (block nil + (cond + ((not shadowing) + (unintern usym u)) + ((symbol-recycled-p usym) + (shadowing-import sym u)) + (t (return))) + (when (eq ustat :external) + (ensure-exported name sym u)))))))) + (assert (soft-upgrade-p upgrade)) + (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 + :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) + (package-names p)) + :do (DBG (package-names discarded) n) + :do (if n (rename-package discarded (first n) (rest n)) + (delete-package* discarded))) + (rename-package package name nicknames) + (DBG :unuse) + (loop :for p :in (set-difference (package-use-list package) (append mix use)) + :do (unuse-package p package)) + (DBG :unintern) + (dolist (name unintern) (unintern* name package nil)) + (DBG :export?) + (loop :for sym :in export :for name = (string sym) :do + (setf (gethash name exported) t)) + (DBG :reexport) + (loop :for p :in reexport :do + (do-external-symbols (sym p) + (let ((name (string sym))) + (export (find-symbol* name package) package) (setf (gethash name exported) t)))) + (DBG :unexport) + (do-external-symbols (sym package) + (unless (gethash (symbol-name sym) exported) (unexport sym package))) + (DBG :shadow) + (loop :for s :in shadow :for name = (string s) :do + (DBG :sha name) + (setf (gethash name shadowed) t) + (multiple-value-bind (recycled previous) (recycle-symbol name) + (cond + ((or (not previous) (not (member (symbol-package recycle) recycle))) + (ecase (nth-value 1 (find-symbol* name package nil)) + ((nil :inherited) (shadow name package)) + ((:internal :external) (shadowing-import (make-symbol name) package)))) + ((eq previous package) (shadow recycled package)) + (t (unintern* recycled previous) (shadowing-import recycled package))))) (loop :for (p . syms) :in shadowing-import-from :do (DBG :shaif p syms) (dolist (sym syms) (ensure-shadowing-import sym p))) @@ -258,21 +305,17 @@ when the symbol is not found." (DBG :use p sp pp) (do-external-symbols (sym pp) (ensure-inherited sym sp)) (use-package pp package)) - (DBG :intern intern) - (dolist (sym intern) (intern* sym package)) + (DBG :intern) + (loop :for name :being :the :hash-keys :of exported :do + (ensure-symbol name t)) + (dolist (name (append intern fmakunbound fmakunbound-setf)) + (ensure-symbol (string name) t)) + (DBG :cleanup) (do-symbols (sym package) - (DBG :ers sym) - (ensure-registered sym)) - (loop :for p :in reexport :do - (DBG :reex p) - (do-external-symbols (sym p) - (let ((name (string sym))) - (export (find-symbol* name package) package) (setf (gethash name exported) t)))) - (DBG :export export) - (loop :for sym :in export :for name = (string sym) :for symbol = (intern* name package) :do - (export symbol package) (setf (gethash name exported) t)) - (DBG :unexport) - (do-external-symbols (sym package) (unless (gethash (symbol-name sym) exported) (unexport sym package))) + (ensure-symbol (symbol-name sym))) + (DBG :export) + (loop :for name :being :the :hash-keys :of exported :do + (ensure-export name package)) ;; do away with packages with conflicting (nick)names ;; note from ASDF 2.26: ECL might not be liking an early fmakunbound (below #-ecl'ed) (ensure-package-fmakunbound package fmakunbound) diff --git a/pathname.lisp b/pathname.lisp index 576cf6ae..c28f35ca 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -3,6 +3,7 @@ (asdf/package:define-package :asdf/pathname (:recycle :asdf/pathname :asdf) + (:fmakunbound #:translate-pathname*) (:use :common-lisp :asdf/utility) #+gcl<2.7 (:shadowing-import-from :system :*load-pathname*) ;; GCL 2.6 sucks (:export diff --git a/plan.lisp b/plan.lisp index 73bdb7bd..d89b8492 100644 --- a/plan.lisp +++ b/plan.lisp @@ -3,6 +3,7 @@ (asdf/package:define-package :asdf/plan (:recycle :asdf/plan :asdf) + (:fmakunbound #:traverse #:perform-plan #:traverse-action) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action) diff --git a/source-registry.lisp b/source-registry.lisp index 356b2234..c83c8e9b 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -4,6 +4,7 @@ (asdf/package:define-package :asdf/source-registry (:recycle :asdf/source-registry :asdf) + (:fmakunbound #:inherit-source-registry #:process-source-registry #:process-source-registry-directive) (:use :common-lisp :asdf/implementation :asdf/configuration :asdf/utility :asdf/pathname :asdf/os :asdf/find-system) (:export diff --git a/system.lisp b/system.lisp index 82d1e7cd..885070c2 100644 --- a/system.lisp +++ b/system.lisp @@ -3,6 +3,7 @@ (asdf/package:define-package :asdf/system (:recycle :asdf/system :asdf) + (:fmakunbound #:find-system #:system-source-file #:system-relative-pathname #:builtin-system-p) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade :asdf/component) (:export @@ -13,7 +14,7 @@ #:reset-system #:builtin-system-p #:system-description #:system-long-description #:system-author #:system-maintainer #:system-licence #:system-license - #:find-system #:probe-asd ;; forward-reference, defined in find-system + #:find-system #:probe-asd ;; forward-reference, methods defined in find-system #:%set-system-source-file ;; For internal use only. DO NOT USE. #:module-components ;; backward-compatibility. DO NOT USE. #:system-defsystem-depends-on)) diff --git a/test/test-around-compile.script b/test/test-around-compile.script index deae5a48..e6b93bed 100644 --- a/test/test-around-compile.script +++ b/test/test-around-compile.script @@ -11,7 +11,7 @@ (quit-on-error (defsystem test-around-compile :around-compile call-in-base-2 - :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. + ;; :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. :components ((:file "test"))) (load-system 'test-around-compile :force t) (assert (= 3 (funcall 'add10 1)))) ;; add10 must have been compiled in base 2 diff --git a/upgrade.lisp b/upgrade.lisp index f1e5b1b6..0e1180ca 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -24,7 +24,7 @@ ;; "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.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.65") + (asdf-version "2.26.66") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) -- GitLab