Commit 95f4085f authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.65: Much progress on define-package. Basically working, except with using packages.

parent 056f33a9
......@@ -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),
......
;;;; -------------------------------------------------------------------------
;;;; 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)
......
......@@ -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")))
......
;;;; -------------------------------------------------------------------------
;;; 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
......
;;;; -------------------------------------------------------------------------
;;; 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
......
;;;; -------------------------------------------------------------------------
;;;; 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)
......
;;;; -------------------------------------------------------------------------
;;;; 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)
......
;;;; -------------------------------------------------------------------------
;;;; 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)
......
;;;; ---------------------------------------------------------------------------
;;;; 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 ()
......
;;;; -------------------------------------------------------------------------
;;;; 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
......
;;;; -------------------------------------------------------------------------
;;;; 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
......
;;;; -------------------------------------------------------------------------
;;;; 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
......
;;;; -----------------------------------------------------------------------
;;;; 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
......
......@@ -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"))))
;; -*- 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>.
......
;;;; -------------------------------------------------------------------------
;;;; 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
......
;;;; ---------------------------------------------------------------------------
;;;; 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))
......
;;;; -------------------------------------------------------------------------
;;;; 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
......
;;;; -------------------------------------------------------------------------
;;;; 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*
......
;;;; -------------------------------------------------------------------------
;;;; 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
......
;;;; -------------------------------------------------------------------------
;;;; 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
......
;;;; ---------------------------------------------------------------------------
;;;; 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
......
;;;; ---------------------------------------------------------------------------
;;;; 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
......
......@@ -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)