From 95f4085f504c71cb360b9914611322d5bfc1ad4b Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Wed, 9 Jan 2013 14:14:35 -0500 Subject: [PATCH] 2.26.65: Much progress on define-package. Basically working, except with using packages. --- TODO | 9 ++ action.lisp | 3 +- asdf.asd | 2 +- backward-interface.lisp | 4 +- backward-internals.lisp | 3 +- bundle.lisp | 3 +- component.lisp | 6 +- concatenate-source.lisp | 3 +- configuration.lisp | 6 +- defsystem.lisp | 6 +- find-component.lisp | 7 +- find-system.lisp | 3 +- footer.lisp | 3 +- generate-asdf.asd | 2 +- header.lisp | 2 +- implementation.lisp | 3 +- interface.lisp | 4 +- lisp-action.lisp | 3 +- lisp-build.lisp | 3 +- operate.lisp | 4 +- operation.lisp | 4 +- os.lisp | 6 +- output-translations.lisp | 3 +- package.lisp | 260 +++++++++++++++++++++++---------------- pathname.lisp | 6 +- plan.lisp | 6 +- source-registry.lisp | 6 +- system.lisp | 3 +- upgrade.lisp | 5 +- utility.lisp | 6 +- 30 files changed, 232 insertions(+), 152 deletions(-) diff --git a/TODO b/TODO index 1572b399..da4f37e3 100644 --- a/TODO +++ b/TODO @@ -3,6 +3,15 @@ * Split ASDF in parts ** Have it pass test-lisp ** Have it pass test-upgrade +** Get package upgrade right +** The unconditional ensure-package-unused breaks test-encodings.script, + since asdf severs itself from its client package hosting the + defsystem form during defsystem-depends-on. +** Solution 1: emulate hook on the *upgraded-p* solution, either using + explicit flag, explicit version numbers or implicit version information + (e.g. source-code or sxhash thereof, also accounting for dependency + package information). +** Solution 2: Just "do the right thing" with exported symbols. * Make load-op a generic operation that selects the proper strategy for each system, module or file, according to component properties and user-configuration: compile the lisp file then load the fasl (load-compiled-op), diff --git a/action.lisp b/action.lisp index f6479213..10fd3efa 100644 --- a/action.lisp +++ b/action.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Actions -(defpackage :asdf/action +(asdf/package:define-package :asdf/action + (:recycle :asdf/action :asdf) (: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) diff --git a/asdf.asd b/asdf.asd index 87f8f017..ca1ae6e9 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.64" ;; to be automatically updated by bin/bump-revision + :version "2.26.65" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/backward-interface.lisp b/backward-interface.lisp index beaea616..f17ebf56 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;; Backward-compatible interfaces -(defpackage :asdf/backward-interface +(asdf/package:define-package :asdf/backward-interface + (:recycle :asdf/backward-interface :asdf) (: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) @@ -15,7 +16,6 @@ #:operation-on-warnings #:run-shell-command #:system-definition-pathname)) - (in-package :asdf/backward-interface) (defvar *asdf-verbose* nil) ; worked around by cl-protobufs. It was a mistake to introduce it. mea culpa -fare diff --git a/backward-internals.lisp b/backward-internals.lisp index 063e3df4..9a7e4fb7 100644 --- a/backward-internals.lisp +++ b/backward-internals.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;; Internal hacks for backward-compatibility -(defpackage :asdf/backward-internals +(asdf/package:define-package :asdf/backward-internals + (:recycle :asdf/backward-internals :asdf) (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/system :asdf/component :asdf/find-system :asdf/action) (:export ;; for internal use diff --git a/bundle.lisp b/bundle.lisp index 623a3f54..a3fdc86d 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; ASDF-Bundle -(defpackage :asdf/bundle +(asdf/package:define-package :asdf/bundle + (: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 :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) diff --git a/component.lisp b/component.lisp index 2f9e062b..17177b0b 100644 --- a/component.lisp +++ b/component.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Components -(defpackage :asdf/component +(asdf/package:define-package :asdf/component + (:recycle :asdf/component :asdf) (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/upgrade) (:export #:component #:component-find-path @@ -19,8 +20,7 @@ #:component-external-format #:component-encoding #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format - #:*default-encoding* #:*utf-8-external-format* - )) + #:*default-encoding* #:*utf-8-external-format*)) (in-package :asdf/component) (defgeneric* component-name (component) diff --git a/concatenate-source.lisp b/concatenate-source.lisp index 669dbe28..7ad794ec 100644 --- a/concatenate-source.lisp +++ b/concatenate-source.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Concatenate-source -(defpackage :asdf/concatenate-source +(asdf/package:define-package :asdf/concatenate-source + (:recycle :asdf/concatenate-source :asdf) (:use :common-lisp :asdf/utility :asdf/os :asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/defsystem :asdf/action :asdf/lisp-action :asdf/bundle) diff --git a/configuration.lisp b/configuration.lisp index 81c92999..119cec93 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -1,7 +1,8 @@ ;;;; --------------------------------------------------------------------------- ;;;; Generic support for configuration files -(defpackage :asdf/configuration +(asdf/package:define-package :asdf/configuration + (:recycle :asdf/configuration :asdf) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os) (:export #:get-folder-path @@ -13,8 +14,7 @@ #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*clear-configuration-hook* #:clear-configuration #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* - #:resolve-relative-location-component #:resolve-absolute-location-component - )) + #:resolve-relative-location-component #:resolve-absolute-location-component)) (in-package :asdf/configuration) (define-condition invalid-configuration () diff --git a/defsystem.lisp b/defsystem.lisp index f0f7dc04..da47357c 100644 --- a/defsystem.lisp +++ b/defsystem.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Defsystem -(defpackage :asdf/defsystem +(asdf/package:define-package :asdf/defsystem + (:recycle :asdf/defsystem :asdf) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate @@ -9,8 +10,7 @@ #+gcl<2.7 (:shadowing-import-from :asdf/implementation #:type-of) (:export #:defsystem #:do-defsystem #:parse-component-form - #:*default-component-class* - )) + #:*default-component-class*)) (in-package :asdf/defsystem) ;;; Pathname diff --git a/find-component.lisp b/find-component.lisp index f184a1bb..517bb03c 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Finding components -(defpackage :asdf/find-component +(asdf/package:define-package :asdf/find-component + (:recycle :asdf/find-component :asdf) (:use :common-lisp :asdf/utility :asdf/os :asdf/component :asdf/system :asdf/find-system) (:export @@ -12,9 +13,7 @@ #:missing-component #:missing-component-of-version #:retry #:missing-dependency #:missing-dependency-of-version #:missing-requires #:missing-parent - #:missing-required-by #:missing-version - )) - + #:missing-required-by #:missing-version)) (in-package :asdf/find-component) ;;;; Missing component conditions diff --git a/find-system.lisp b/find-system.lisp index 75feca66..c092c1d9 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Finding systems -(defpackage :asdf/find-system +(asdf/package:define-package :asdf/find-system + (:recycle :asdf/find-system :asdf) (:use :common-lisp :asdf/implementation :asdf/utility :asdf/upgrade :asdf/pathname :asdf/os :asdf/component :asdf/system) (:export diff --git a/footer.lisp b/footer.lisp index c1c4ec12..c18db134 100644 --- a/footer.lisp +++ b/footer.lisp @@ -1,7 +1,8 @@ ;;;; ----------------------------------------------------------------------- ;;;; ASDF Footer: last words and cleanup -(defpackage :asdf/footer +(asdf/package:define-package :asdf/footer + (:recycle :asdf/footer :asdf) (:use :common-lisp :asdf/package :asdf/implementation :asdf/utility :asdf/pathname :asdf/os :asdf/lisp-build diff --git a/generate-asdf.asd b/generate-asdf.asd index 494e51f0..b01f7df5 100644 --- a/generate-asdf.asd +++ b/generate-asdf.asd @@ -53,5 +53,5 @@ (:file "bundle" :depends-on ("lisp-action")) (:file "concatenate-source" :depends-on ("lisp-action")) (:file "backward-interface" :depends-on ("lisp-action")))) - (:file "user") + (:file "interface") (:file "footer" :depends-on ("interface")))) diff --git a/header.lisp b/header.lisp index 75cf1595..24e9d672 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.64: Another System Definition Facility. +;;; This is ASDF 2.26.65: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/implementation.lisp b/implementation.lisp index efb8aabc..ae9bfe19 100644 --- a/implementation.lisp +++ b/implementation.lisp @@ -1,8 +1,9 @@ ;;;; ------------------------------------------------------------------------- ;;;; Handle ASDF portability to multiple implementations -(defpackage :asdf/implementation +(asdf/package:define-package :asdf/implementation (:use :common-lisp :asdf/package) + (:recycle :asdf/implementation :asdf) #+cormanlisp (:export #:logical-pathname #:translate-logical-pathname diff --git a/interface.lisp b/interface.lisp index 446c0996..e23f0ecc 100644 --- a/interface.lisp +++ b/interface.lisp @@ -1,7 +1,8 @@ ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. -(defpackage :asdf/interface +(asdf/package:define-package :asdf/interface + (:recycle :asdf/interface :asdf) (:nicknames :asdf) (:use :common-lisp :asdf/package :asdf/implementation :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade @@ -127,7 +128,6 @@ #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory)) - (in-package :asdf/interface) (with-upgrade (:when (fboundp 'make-sub-operation)) diff --git a/lisp-action.lisp b/lisp-action.lisp index fd9be8a9..eba3a510 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Actions to build Common Lisp software -(defpackage :asdf/lisp-action +(asdf/package:define-package :asdf/lisp-action + (:recycle :asdf/lisp-action :asdf) (:use :common-lisp :asdf/utility :asdf/lisp-build :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action) (:export diff --git a/lisp-build.lisp b/lisp-build.lisp index f07b334c..52f0baca 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Support to build (compile and load) Lisp files -(defpackage :asdf/lisp-build +(asdf/package:define-package :asdf/lisp-build + (:recycle :asdf/lisp-build :asdf) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os) (:export #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* diff --git a/operate.lisp b/operate.lisp index cfaed627..343cf906 100644 --- a/operate.lisp +++ b/operate.lisp @@ -1,6 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Invoking Operations -(defpackage :asdf/operate + +(asdf/package:define-package :asdf/operate + (:recycle :asdf/operate :asdf) (: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/operation.lisp b/operation.lisp index 37287c3a..6aad910d 100644 --- a/operation.lisp +++ b/operation.lisp @@ -1,14 +1,14 @@ ;;;; ------------------------------------------------------------------------- ;;;; Operations -(defpackage :asdf/operation +(asdf/package:define-package :asdf/operation + (:recycle :asdf/operation :asdf) (:use :common-lisp :asdf/utility :asdf/upgrade) (:export #:operation #:operation-original-initargs ;; backward-compatibility only. DO NOT USE. #:make-operation #:find-operation)) - (in-package :asdf/operation) ;;; Operation Classes diff --git a/os.lisp b/os.lisp index ae621ca8..fd1ae826 100644 --- a/os.lisp +++ b/os.lisp @@ -1,6 +1,8 @@ ;;;; --------------------------------------------------------------------------- -;;;; Access to the Operating System -(defpackage :asdf/os +;;;; Access to the Operating System + +(asdf/package:define-package :asdf/os + (:recycle :asdf/os :asdf) (:use :cl :asdf/package :asdf/implementation :asdf/utility :asdf/pathname) (:export #:featurep #:os-unix-p #:os-windows-p ;; features diff --git a/output-translations.lisp b/output-translations.lisp index 9895b116..06c464c1 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -1,7 +1,8 @@ ;;;; --------------------------------------------------------------------------- ;;;; asdf-output-translations -(defpackage :asdf/output-translations +(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) (:export #:invalid-output-translation diff --git a/package.lisp b/package.lisp index fd863d47..8fa3ec13 100644 --- a/package.lisp +++ b/package.lisp @@ -13,60 +13,104 @@ (defpackage :asdf/package (:use :common-lisp) (:export - #:find-symbol* #:present-symbol-p #:present-symbols - #:intern* #:remove-symbol #:unlink-package #:ensure-package - #:define-package)) + #:find-package* #:package-name* #:find-symbol* #:intern* #:unintern* + #:unlink-package #:ensure-package #:define-package #:package-data)) (in-package :asdf/package) +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(defmacro DBG (tag &rest exprs) + "simple debug statement macro: +outputs a tag plus a list of variable and their values, returns the last value" + ;"if not in debugging mode, just compute and return last value" + #-DBGXXX (declare (ignore tag)) #-DBGXXX (car (last exprs)) #+DBGXXX + (let ((res (gensym))(f (gensym))) + `(let (,res (*print-readably* nil)) + (flet ((,f (fmt &rest args) (apply #'format *error-output* fmt args))) + (fresh-line *standard-output*) (fresh-line *trace-output*) (fresh-line *error-output*) + (,f "~&~A~%" ,tag) + ,@(mapcan + #'(lambda (x) + `((,f "~& ~S => " ',x) + (,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x))))) + exprs) + (apply 'values ,res))))) + ;;;; General purpose package utilities (eval-when (:load-toplevel :compile-toplevel :execute) - (defun find-symbol* (name package-name &optional (error t)) + (defun find-package* (package-designator &optional (error t)) + (let ((package (find-package package-designator))) + (cond + (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 by letting you supply a symbol or keyword for the name; also works well when the package is not present. If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found." - (let ((package (find-package package-name))) - (if package - (let ((symbol (find-symbol (string name) package))) - (or symbol - (when error - (error "There is no symbol ~A in package ~A" name package-name)))) - (when error - (error "There is no package ~A" package-name))))) - (defun intern* (name package) - (intern (string name) package)) - (defun remove-symbol (symbol package) - (let ((sym (find-symbol* symbol package nil))) - (when sym - #-cormanlisp (unexport sym package) - (unintern sym package) - sym))) - (defun present-symbol-p (symbol package) - (member (nth-value 1 (find-symbol* symbol package nil)) '(:internal :external))) - (defun present-symbols (package) - ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera - (let (l) (do-symbols (s package) (when (present-symbol-p s package) (push s l))) (reverse l)))) + (block nil + (let ((package (find-package* package-designator error))) + (when package + (multiple-value-bind (symbol status) (find-symbol (string name) package) + (cond + (status (return (values symbol status))) + (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))) + (defun unintern* (name package-designator &optional (error t)) + (block nil + (let ((package (find-package* package-designator error))) + (when package + (multiple-value-bind (symbol status) (find-symbol* name package error) + (cond + (status (unintern symbol package) + (return (values symbol status))) + (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)) + (let ((package (find-package* package-designator error))) + (when package + (labels ((string-sort (strings) + (sort strings #'string<)) + (sort-packages (packages) + (string-sort (mapcar #'package-name packages)))) + (loop :with internal :with external :with inherited + :for sym :being :the :symbols :in package + :for status = (nth-value 1 (find-symbol* sym package)) :do + (ecase status + (:internal (push sym internal)) + (:external (push sym external)) + (:inherited (push sym inherited))) + :finally + (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)) + :use ,(sort-packages (package-use-list package)) + :used-by ,(sort-packages (package-used-by-list package)))))))))) (eval-when (:load-toplevel :compile-toplevel :execute) (defun soft-upgrade-p (upgrade) (ecase upgrade ((:soft nil) t) (:hard nil))) - (defun check-packages-exist (package-names) - (remove-duplicates - (loop :for n :in package-names - :for p = (find-package n) - :when p :collect p :else :do (error "Package ~A does not exist" n)) - :from-end t)) (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 (let ((p (find-package package))) (when p - ;;(unless (soft-upgrade-p upgrade) (ensure-package-unintern p (present-symbols u))) (ensure-package-unused p) (delete-package package)))) (defun ensure-package-fmakunbound (package symbols) @@ -77,20 +121,10 @@ 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 ensure-package-unintern (package unintern &key table (users (list-all-packages))) - (loop :for u :in unintern - :for name = (string u) - :for removed = (remove-symbol name package) :do - (when removed - (loop :for p :in users :do - (when (eq removed (find-symbol name p)) - (unintern removed p))))))) - -(eval-when (:load-toplevel :compile-toplevel :execute) (defun recycle-symbol (name recycle) (loop :for r :in recycle :for s = (find-symbol* name r nil) - :when s :do (values s r))) + :when s :do (return (values s r)))) (defun ensure-package (name &key upgrade nicknames documentation use @@ -99,7 +133,6 @@ when the symbol is not found." recycle mix reexport unintern fmakunbound fmakunbound-setf) (let* ((nicknames (mapcar #'string nicknames)) - (use (check-packages-exist use)) (shadow (mapcar #'string shadow)) (shadowing-import-from (loop :for sif :in shadowing-import-from :collect (mapcar #'string sif))) @@ -107,24 +140,31 @@ when the symbol is not found." :collect (mapcar #'string if))) (export (mapcar #'string export)) (recycle (remove nil (mapcar #'find-package recycle))) - (mix (check-packages-exist mix)) - (shadowed (make-hash-table :test 'equal)) - (inherited (make-hash-table :test 'equal)) - (imported (make-hash-table :test 'equal)) - (exported (make-hash-table :test 'equal)) + (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 (previous (remove-duplicates (mapcar #'find-package (cons name nicknames)) :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) (remove-symbol name package)) + (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 @@ -133,104 +173,115 @@ when the symbol is not found." ((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))))) + (t (unintern* recycled previous) (shadowing-import recycled package))))) (labels ((ensure-shadowing-import (sym p) (let* ((name (string sym)) (i (find-symbol* name p))) (cond ((gethash name shadowed) - (unless (eq i (gethash name imported)) + (unless (eq i (find-symbol* name package)) (error "Conflicting shadowings for ~A" name))) (t (setf (gethash name shadowed) t) - (setf (gethash name imported) i) + (setf (gethash name imported) t) (shadowing-import package))))) (ensure-import (sym p) (let* ((name (string sym)) (i (find-symbol* name p))) - (multiple-value-bind (ii ip) (gethash name imported) + (multiple-value-bind (x xp) (find-symbol name package) (cond - (ip - (unless (eq i ii) + ((gethash name imported) + (unless (eq i x) (error "Can't import ~S from both ~S and ~S" - name (package-name (symbol-package ii)) (package-name p)))) + name (package-name (symbol-package x)) (package-name p)))) ((gethash name shadowed) (error "Can't both shadow ~S and import it from ~S" name (package-name p))) (t - (multiple-value-bind (x xp) (find-symbol name package) - (when (and xp (not (eq i x))) - (unintern x package)) - (import i package))))))) + (when (and xp (not (eq i x))) + (unintern* x package)) + (setf (gethash name imported) t) + (import i package)))))) (ensure-mix (sym p) (let* ((name (string sym)) - (i (find-symbol* name p))) - (unless (or (gethash name shadowed) (nth-value 1 (gethash name imported))) - (multiple-value-bind (in inp) (gethash name inherited) + (sp (string p))) + (unless (or (gethash name shadowed) (gethash name imported)) + (let ((ip (gethash name inherited))) (cond - ((eq i in)) - (inp + ((eq sp ip)) + (ip (remhash name inherited) - (ensure-shadowing-import name (symbol-package in))) + (ensure-shadowing-import name ip)) (t - (ensure-inherited sym p))))))) + (ensure-inherited sym sp))))))) (ensure-inherited (sym p) (let* ((name (string sym)) - (i (find-symbol* name p))) - (multiple-value-bind (in inp) (gethash name inherited) - (multiple-value-bind (im imp) (gethash name imported) - (cond - (inp - (unless (eq i in) - (error "Can't inherit ~S from ~S, it is inherited from ~S" - name (package-name p) (package-name (symbol-package in))))) - (imp - (unless (eq i im) - (error "Can't inherit ~S from ~S, it is imported from ~S" - name (package-name p) (package-name (symbol-package im))))) - ((gethash name shadowed) - (error "Can't inherit ~S from ~S, it is shadowed" name (package-name p))) - (t - (multiple-value-bind (x xp) (find-symbol name package) - (when xp - (unintern x package))))))))) - (ensure-registered-symbol (sym) + (sp (string p)) + (s (find-symbol* name sp)) + (ip (gethash name inherited))) + (multiple-value-bind (x xp) (find-symbol name package) + (cond + (ip + (unless (eq ip sp) + (error "Can't inherit ~S from ~S, it is inherited from ~S" + name sp ip))) + ((gethash name imported) + (unless (eq s x) + (error "Can't inherit ~S from ~S, it is imported from ~S" + name sp (package-name (symbol-package x))))) + ((gethash name shadowed) + (error "Can't inherit ~S from ~S, it is shadowed" name sp)) + (t + (when xp + (unintern* x package))))))) + (ensure-registered (sym) (let ((name (string sym))) (unless (or (gethash name shadowed) - (nth-value 1 (gethash name imported)) - (nth-value 1 (gethash name inherited))) + (gethash name imported) + (gethash name inherited)) (multiple-value-bind (recycled previous) (recycle-symbol name recycle) (cond - ((or (not previous) (not (member (symbol-package recycle) recycle))) - (unintern sym package)) + ((or (not previous) (not (member (symbol-package recycled) recycle))) + (unintern* sym package)) ((eq previous package)) - (t (unintern recycled previous) (import recycled package)))))))) + (t (unintern* recycled previous) (import recycled package)))))))) (loop :for (p . syms) :in shadowing-import-from :do + (DBG :shaif p syms) (dolist (sym syms) (ensure-shadowing-import sym p))) (loop :for p :in mix :do + (DBG :mix p) (do-external-symbols (sym p) (ensure-mix sym p))) (loop :for (p . syms) :in import-from :do + (DBG :if p syms) (dolist (sym syms) (ensure-import sym p))) - (loop :for p :in use :do - (do-external-symbols (sym p) (ensure-inherited sym p))) - (loop :for p :in use :do (use-package p package)) + (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)) + (use-package pp package)) + (DBG :intern intern) (dolist (sym intern) (intern* sym package)) (do-symbols (sym package) - (ensure-registered-symbol sym)) + (DBG :ers sym) + (ensure-registered sym)) (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)))) - (dolist (sym export) (export sym package) (setf (gethash sym exported) t)) - (do-external-symbols (sym package) (unless (gethash sym exported) (unexport sym))) + (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))) ;; 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) (ensure-package-fmakunbound-setf package fmakunbound-setf) + ;;#+DBG (untrace) package)))) (eval-when (:load-toplevel :compile-toplevel :execute) - (defun parse-define-package-clauses (package clauses) + (defun parse-define-package-form (package clauses) (loop :with use-p = nil :with recycle-p = nil :with documentation = nil :with upgrade = nil @@ -258,7 +309,8 @@ when the symbol is not found." (error "define-package: bad :upgrade directive")) (setf upgrade (car args)) :else :do (error "unrecognized define-package keyword ~S" kw) - :finally (return `(:nicknames ,nicknames :documentation ,documentation + :finally (return `(,package + :nicknames ,nicknames :documentation ,documentation :use ,(if use-p use '(:common-lisp)) :shadow ,shadow :shadowing-import-from ,shadowing-import-from :import-from ,import-from :export ,export :intern ,intern @@ -270,4 +322,4 @@ when the symbol is not found." (defmacro define-package (package &rest clauses) `(eval-when (:compile-toplevel :load-toplevel :execute) #+gcl (defpackage ,package (:use)) - (apply 'ensure-package ',(parse-define-package-clauses package clauses)))) + (apply 'ensure-package ',(parse-define-package-form package clauses)))) diff --git a/pathname.lisp b/pathname.lisp index ad40192f..576cf6ae 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -1,4 +1,8 @@ -(defpackage :asdf/pathname +;;;; ------------------------------------------------------------------------- +;;;; Portability layer around Common Lisp pathnames + +(asdf/package:define-package :asdf/pathname + (:recycle :asdf/pathname :asdf) (: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 11581ba7..73bdb7bd 100644 --- a/plan.lisp +++ b/plan.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Plan -(cl:defpackage :asdf/plan +(asdf/package:define-package :asdf/plan + (:recycle :asdf/plan :asdf) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action) @@ -18,8 +19,7 @@ #:call-while-visiting-action #:while-visiting-action #:traverse-sequentially #:traverse #:perform-plan #:plan-operates-on-p)) - -(cl:in-package :asdf/plan) +(in-package :asdf/plan) ;;;; Planned action status diff --git a/source-registry.lisp b/source-registry.lisp index 6b7a4f7b..356b2234 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -2,7 +2,8 @@ ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 -(defpackage :asdf/source-registry +(asdf/package:define-package :asdf/source-registry + (:recycle :asdf/source-registry :asdf) (:use :common-lisp :asdf/implementation :asdf/configuration :asdf/utility :asdf/pathname :asdf/os :asdf/find-system) (:export @@ -20,8 +21,7 @@ #:user-source-registry-directory #:system-source-registry-directory #:environment-source-registry #:process-source-registry #:compute-source-registry #:flatten-source-registry - #:sysdef-source-registry-search - )) + #:sysdef-source-registry-search)) (in-package :asdf/source-registry) (define-condition invalid-source-registry (invalid-configuration warning) diff --git a/system.lisp b/system.lisp index d5115b5d..82d1e7cd 100644 --- a/system.lisp +++ b/system.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; Systems -(defpackage :asdf/system +(asdf/package:define-package :asdf/system + (:recycle :asdf/system :asdf) (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade :asdf/component) (:export diff --git a/upgrade.lisp b/upgrade.lisp index 0e559518..f1e5b1b6 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -2,7 +2,8 @@ ;;;; Handle upgrade as forward- and backward-compatibly as possible ;; See https://bugs.launchpad.net/asdf/+bug/485687 -(defpackage :asdf/upgrade +(asdf/package:define-package :asdf/upgrade + (:recycle :asdf/upgrade :asdf) (:use :common-lisp :asdf/package :asdf/implementation :asdf/utility) (:export #:upgrade-asdf #:asdf-upgrade-error #:with-upgrade @@ -23,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.64") + (asdf-version "2.26.65") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) diff --git a/utility.lisp b/utility.lisp index fdce626d..677f2876 100644 --- a/utility.lisp +++ b/utility.lisp @@ -1,7 +1,8 @@ ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF -(defpackage :asdf/utility +(asdf/package:define-package :asdf/utility + (:recycle :asdf/utility :asdf) (:use :common-lisp :asdf/package :asdf/implementation) (:export #:find-symbol* ;; reexport from asdf/package @@ -16,8 +17,7 @@ #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f #:list-to-hash-set ;; hash-table #:ensure-function ;; functions - #:parse-version #:version-compatible-p ;; version - )) + #:parse-version #:version-compatible-p)) ;; version (in-package :asdf/utility) ;;; *-defining macros -- GitLab