Commit 056f33a9 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.64: checkpointing progress with define-package

parent 4b1cea29
......@@ -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")))
......
......@@ -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"))
......
;; -*- 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>.
......
......@@ -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))))
......@@ -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:
;;;;
......
......@@ -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))))
......
......@@ -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)))
......
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