(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)
(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
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)))
: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
((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
(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
(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))))
common-lisp.net / projects/asdf/asdf.git / commitdiff
