From 056f33a907f9ae3ffe5e0ae6aaa5f3b6f5bc863a Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Wed, 9 Jan 2013 07:43:10 -0500 Subject: [PATCH] 2.26.64: checkpointing progress with define-package --- asdf.asd | 2 +- generate-asdf.asd | 16 +- header.lisp | 2 +- package.lisp | 334 ++++++++++++++++++++++++--------------- pathname.lisp | 8 +- test/script-support.lisp | 4 +- upgrade.lisp | 2 +- 7 files changed, 228 insertions(+), 140 deletions(-) diff --git a/asdf.asd b/asdf.asd index c49b91329..87f8f017f 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.63" ;; to be automatically updated by bin/bump-revision + :version "2.26.64" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/generate-asdf.asd b/generate-asdf.asd index 87b78efeb..494e51f0f 100644 --- a/generate-asdf.asd +++ b/generate-asdf.asd @@ -26,24 +26,26 @@ :components ((:file "header") (:module - "code" :pathname "" :components + "utils" :pathname "" :components ((:file "package") (:file "implementation" :depends-on ("package")) (:file "utility" :depends-on ("implementation")) (:file "pathname" :depends-on ("utility")) - (:file "os" :depends-on ("pathname")) - (:file "upgrade" :depends-on ("utility")) - (:file "component" :depends-on ("pathname")) + (:file "os" :depends-on ("pathname")))) + (:module + "code" :pathname "" :components + (:file "upgrade") + (:file "component") (:file "system" :depends-on ("component")) (:file "find-system" :depends-on ("system")) (:file "find-component" :depends-on ("find-system")) - (:file "lisp-build" :depends-on ("pathname")) - (:file "operation" :depends-on ("utility")) + (:file "lisp-build") + (:file "operation") (:file "action" :depends-on ("find-component" "operation")) (:file "lisp-action" :depends-on ("action" "lisp-build")) (:file "plan" :depends-on ("action")) (:file "operate" :depends-on ("plan")) - (:file "configuration" :depends-on ("pathname")) + (:file "configuration") (:file "output-translations" :depends-on ("configuration" "operate")) (:file "source-registry" :depends-on ("configuration" "find-system")) (:file "backward-internals" :depends-on ("action" "operate")) diff --git a/header.lisp b/header.lisp index 4c46d1051..75cf1595a 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.63: Another System Definition Facility. +;;; This is ASDF 2.26.64: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/package.lisp b/package.lisp index 40614aaae..fd863d476 100644 --- a/package.lisp +++ b/package.lisp @@ -13,7 +13,9 @@ (defpackage :asdf/package (:use :common-lisp) (:export - #:find-symbol* #:define-package)) + #:find-symbol* #:present-symbol-p #:present-symbols + #:intern* #:remove-symbol #:unlink-package #:ensure-package + #:define-package)) (in-package :asdf/package) @@ -38,152 +40,234 @@ when the symbol is not found." (defun intern* (name package) (intern (string name) package)) (defun remove-symbol (symbol package) - (let ((sym (find-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)) '(:internal :external))) + (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))) - (defun ensure-package-use (package use) - (dolist (used (package-use-list package)) - (unless (member (package-name used) use :test 'string=) - (unuse-package used) - (do-external-symbols (sym used) - (when (eq sym (find-symbol* sym package)) - (remove-symbol sym package))))) - (dolist (used (reverse use)) - (do-external-symbols (sym used) - (unless (eq sym (find-symbol* sym package)) - (remove-symbol sym package))) - (use-package used package))) - (defun ensure-package-unintern (package symbols) - (loop :with packages = (list-all-packages) - :for sym :in symbols - :for removed = (remove-symbol sym package) - :when removed :do - (loop :for p :in packages :do - (when (eq removed (find-symbol* sym p)) - (unintern removed p))))) - (defun unlink-package (package) - (let ((u (find-package package))) - (when u - (ensure-package-unintern u (present-symbols u)) - (loop :for p :in (package-used-by-list u) :do - (unuse-package u p)) - (delete-package u)))) - (defun ensure-package-exists (name nicknames use) - (let ((previous - (remove-duplicates - (mapcar #'find-package (cons name nicknames)) - :from-end t))) - ;; do away with packages with conflicting (nick)names - (map () #'unlink-package (cdr previous)) - ;; reuse previous package with same name - (let ((p (car previous))) - (cond - (p - (rename-package p name nicknames) - (ensure-package-use p use) - p) - (t - (make-package name :nicknames nicknames :use use)))))) - (defun ensure-package-shadow (package symbols) - (shadow symbols package)) + (let (l) (do-symbols (s package) (when (present-symbol-p s package) (push s l))) (reverse l)))) + +(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) (loop :for name :in symbols - :for sym = (find-symbol* name package) + :for sym = (find-symbol* name package nil) :when sym :do (fmakunbound sym))) (defun ensure-package-fmakunbound-setf (package symbols) (loop :for name :in symbols - :for sym = (find-symbol* name package) + :for sym = (find-symbol* name package nil) :when sym :do #-gcl (fmakunbound `(setf ,sym)))) - (defun ensure-package-export (package export) - (let ((formerly-exported-symbols nil) - (bothly-exported-symbols nil) - (newly-exported-symbols nil)) - (do-external-symbols (sym package) - (if (member sym export :test 'string-equal) - (push sym bothly-exported-symbols) - (push sym formerly-exported-symbols))) - (loop :for sym :in export :do - (unless (member sym bothly-exported-symbols :test 'equal) - (push sym newly-exported-symbols))) - (loop :for user :in (package-used-by-list package) - :for shadowing = (package-shadowing-symbols user) :do - (loop :for new :in newly-exported-symbols - :for old = (find-symbol* new user) - :when (and old (not (member old shadowing))) - :do (unintern old user))) - (loop :for x :in newly-exported-symbols :do - (export (intern* x package))))) + (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))) (defun ensure-package (name &key - nicknames use intern unintern shadow export - import-from shadowing-import-from - recycle mix fmakunbound fmakunbound-setf) - recycle mix intern import-from shadowing-import-from - (let* ((p (ensure-package-exists name nicknames use))) - #-ecl (ensure-package-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL - #-ecl (ensure-package-fmakunbound-setf p fmakunbound-setf) #+ecl fmakunbound-setf - (ensure-package-unintern p unintern) - (ensure-package-shadow p shadow) - (ensure-package-export p export) - p)) -#| - (let ((h (make-hash-table :test 'equal))) - (labels ((ensure-imported (n) - (let* ((s (string n)) - (x (gethash s h))) - (unless x (setf (gethash s h) t)) - x)) - (import-from (package) - (loop :for s :being :each :external-symbol :in package - :for n = (symbol-name s) - :unless (ensure-imported n) - :collect n))) - ;; First, mark the symbols explicitly imported by the user - (loop :for (kw . ()) :in clauses - :when (member kw '(:import-from :shadowing-import-from)) :do - (map () #'ensure-imported (cddr clauses))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (ensure-package - ',name :nicknames ',nicknames :use ',use :export ',export - :shadow ',shadow :unintern ',unintern - :fmakunbound ',fmakunbound :fmakunbound-setf ',fmakunbound-setf))) - `(defpackage ,package (:use) - ,@(loop :for p :in mixed-packages - :collect `(:import-from ,p ,@(import-from p))) - ,@clauses - (:export ,@(loop :for s :being :the :hash-keys :of h :collect s))))))) -|# - (defun parse-define-package-clauses (clauses) - (loop :for (kw . args) :in clauses + upgrade + nicknames documentation use + shadow shadowing-import-from + import-from export intern + 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))) + (import-from (loop :for if :in import-from + :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)) + (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) + (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)) + ;;; Compute the desired state of the package + (loop :for sym :in shadow :for name = (string sym) :do + (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))))) + (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)) + (error "Conflicting shadowings for ~A" name))) + (t + (setf (gethash name shadowed) t) + (setf (gethash name imported) i) + (shadowing-import package))))) + (ensure-import (sym p) + (let* ((name (string sym)) + (i (find-symbol* name p))) + (multiple-value-bind (ii ip) (gethash name imported) + (cond + (ip + (unless (eq i ii) + (error "Can't import ~S from both ~S and ~S" + name (package-name (symbol-package ii)) (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))))))) + (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) + (cond + ((eq i in)) + (inp + (remhash name inherited) + (ensure-shadowing-import name (symbol-package in))) + (t + (ensure-inherited sym p))))))) + (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) + (let ((name (string sym))) + (unless (or (gethash name shadowed) + (nth-value 1 (gethash name imported)) + (nth-value 1 (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)) + ((eq previous package)) + (t (unintern recycled previous) (import recycled package)))))))) + (loop :for (p . syms) :in shadowing-import-from :do + (dolist (sym syms) (ensure-shadowing-import sym p))) + (loop :for p :in mix :do + (do-external-symbols (sym p) (ensure-mix sym p))) + (loop :for (p . syms) :in import-from :do + (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)) + (dolist (sym intern) (intern* sym package)) + (do-symbols (sym package) + (ensure-registered-symbol 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))) + ;; 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) + package)))) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun parse-define-package-clauses (package clauses) + (loop + :with use-p = nil :with recycle-p = nil + :with documentation = nil :with upgrade = nil + :for (kw . args) :in clauses :when (eq kw :nicknames) :append args :into nicknames :else - :when (eq kw :use) :append args :into use :else + :when (eq kw :documentation) + :do (cond + (documentation (error "define-package: can't define documentation twice")) + ((or (atom args) (cdr args)) (error "define-package: bad documentation")) + (t (setf documentation (car args)))) :else + :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else :when (eq kw :shadow) :append args :into shadow :else + :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else + :when (eq kw :import-from) :collect args :into import-from :else :when (eq kw :export) :append args :into export :else :when (eq kw :intern) :append args :into intern :else - :when (eq kw :import-from) :collect args :into import-from :else - :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else - :when (eq kw :recycle) :append args :into recycle :else + :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else :when (eq kw :mix) :append args :into mix :else + :when (eq kw :reexport) :append args :into reexport :else :when (eq kw :unintern) :append args :into unintern :else :when (eq kw :fmakunbound) :append args :into fmakunbound :else :when (eq kw :fmakunbound-setf) :append args :into fmakunbound-setf :else - :do (error "unrecognized define-package keyword ~S" kw) - :finally (return `(:nicknames ,nicknames :use ,use - :shadow ,shadow :export ,export :intern ,intern - :import-from ,import-from :shadowing-import-from ,shadowing-import-from - :recycle ,recycle :mix ,mix :unintern ,unintern - :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf)))) -);eval-when + :when (eq kw :upgrade) + :do (unless (and (consp args) (null (cdr args)) (member (car args) '(:soft :hard)) (null upgrade)) + (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 + :use ,(if use-p use '(:common-lisp)) + :shadow ,shadow :shadowing-import-from ,shadowing-import-from + :import-from ,import-from :export ,export :intern ,intern + :recycle ,(if recycle-p recycle (cons package nicknames)) + :mix ,mix :reexport ,reexport :unintern ,unintern + ,@(when upgrade `(:upgrade ,upgrade)) + :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf))))) (defmacro define-package (package &rest clauses) `(eval-when (:compile-toplevel :load-toplevel :execute) - (apply 'ensure-package ',package ',(parse-define-package-clauses clauses)))) + #+gcl (defpackage ,package (:use)) + (apply 'ensure-package ',(parse-define-package-clauses package clauses)))) diff --git a/pathname.lisp b/pathname.lisp index 01bdf0d59..ad40192f1 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -706,8 +706,7 @@ For the latter case, we ought pick random suffix and atomically open it." (defun* physical-pathname-p (x) (and (pathnamep x) (not (typep x 'logical-pathname)))) -(defun* sane-physical-pathname (&key (defaults *default-pathname-defaults*) - fallback (keep t) must-exist) +(defun* sane-physical-pathname (defaults &key (keep t) fallback must-exist) (flet ((sanitize (x) (setf x (and x (ignore-errors (translate-logical-pathname x)))) (when (pathnamep x) @@ -722,10 +721,13 @@ For the latter case, we ought pick random suffix and atomically open it." (setf x (and (probe-file* x) x))) (and (physical-pathname-p x) x)))) (or (sanitize defaults) - (when fallback (sanitize (ignore-errors (user-homedir-pathname)))) + (when fallback + (or (sanitize (ignore-errors (user-homedir-pathname))) + (sanitize (nil-pathname)))) (error "Could not find a sanitize ~S ~:[~;or a fallback ~] into a physical pathname" defaults fallback)))) + ;;;; ----------------------------------------------------------------- ;;;; Windows shortcut support. Based on: ;;;; diff --git a/test/script-support.lisp b/test/script-support.lisp index f3d04415a..f24f9e6ed 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -63,9 +63,9 @@ (let ((old-asdf (merge-pathnames (make-pathname :directory `(#-gcl :relative "tmp") - :name (format nil "asdf-~A" tag) + :name (format nil "asdf-~A" tag) :type "lisp" :defaults *asdf-directory*) - *asdf-lisp*))) + *asdf-directory*))) (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)) (load old-asdf)))) diff --git a/upgrade.lisp b/upgrade.lisp index a8fcec8c5..0e5595185 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -23,7 +23,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.63") + (asdf-version "2.26.64") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) -- GitLab