Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
A
asdf
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Didier Verna
asdf
Commits
95f4085f
Commit
95f4085f
authored
Jan 09, 2013
by
Francois-Rene Rideau
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
2.26.65: Much progress on define-package. Basically working, except with using packages.
parent
056f33a9
Changes
30
Hide whitespace changes
Inline
Side-by-side
Showing
30 changed files
with
232 additions
and
152 deletions
+232
-152
TODO
TODO
+9
-0
action.lisp
action.lisp
+2
-1
asdf.asd
asdf.asd
+1
-1
backward-interface.lisp
backward-interface.lisp
+2
-2
backward-internals.lisp
backward-internals.lisp
+2
-1
bundle.lisp
bundle.lisp
+2
-1
component.lisp
component.lisp
+3
-3
concatenate-source.lisp
concatenate-source.lisp
+2
-1
configuration.lisp
configuration.lisp
+3
-3
defsystem.lisp
defsystem.lisp
+3
-3
find-component.lisp
find-component.lisp
+3
-4
find-system.lisp
find-system.lisp
+2
-1
footer.lisp
footer.lisp
+2
-1
generate-asdf.asd
generate-asdf.asd
+1
-1
header.lisp
header.lisp
+1
-1
implementation.lisp
implementation.lisp
+2
-1
interface.lisp
interface.lisp
+2
-2
lisp-action.lisp
lisp-action.lisp
+2
-1
lisp-build.lisp
lisp-build.lisp
+2
-1
operate.lisp
operate.lisp
+3
-1
operation.lisp
operation.lisp
+2
-2
os.lisp
os.lisp
+4
-2
output-translations.lisp
output-translations.lisp
+2
-1
package.lisp
package.lisp
+156
-104
pathname.lisp
pathname.lisp
+5
-1
plan.lisp
plan.lisp
+3
-3
source-registry.lisp
source-registry.lisp
+3
-3
system.lisp
system.lisp
+2
-1
upgrade.lisp
upgrade.lisp
+3
-2
utility.lisp
utility.lisp
+3
-3
No files found.
TODO
View file @
95f4085f
...
...
@@ -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),
...
...
action.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
)
...
...
asdf.asd
View file @
95f4085f
...
...
@@ -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.6
4
"
;; to be automatically updated by bin/bump-revision
:version
"2.26.6
5
"
;; to be automatically updated by bin/bump-revision
:depends-on
()
:components
((
:file
"asdf"
)))
...
...
backward-interface.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;; 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
...
...
backward-internals.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;; 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
...
...
bundle.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
)
...
...
component.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
)
...
...
configuration.lisp
View file @
95f4085f
;;;; ---------------------------------------------------------------------------
;;;; 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.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
...
...
find-component.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
...
...
find-system.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
...
...
footer.lisp
View file @
95f4085f
;;;; -----------------------------------------------------------------------
;;;; 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
...
...
generate-asdf.asd
View file @
95f4085f
...
...
@@ -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"
)))
)
header.lisp
View file @
95f4085f
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.6
4
: Another System Definition Facility.
;;; This is ASDF 2.26.6
5
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
implementation.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; Handle ASDF portability to multiple implementations
(
def
package
:asdf/implementation
(
asdf/package:define-
package
:asdf/implementation
(
:use
:common-lisp
:asdf/package
)
(
:recycle
:asdf/implementation
:asdf
)
#+
cormanlisp
(
:export
#:logical-pathname
#:translate-logical-pathname
...
...
interface.lisp
View file @
95f4085f
;;;; ---------------------------------------------------------------------------
;;;; 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
))
...
...
lisp-action.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
...
...
lisp-build.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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*
...
...
operate.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
...
...
operation.lisp
View file @
95f4085f
;;;; -------------------------------------------------------------------------
;;;; 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
...
...
os.lisp
View file @
95f4085f
;;;; ---------------------------------------------------------------------------
;;;; 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
...
...
output-translations.lisp
View file @
95f4085f
;;;; ---------------------------------------------------------------------------
;;;; 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
...
...
package.lisp
View file @
95f4085f
...
...
@@ -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
))
(
i
n
p
((
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
s
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
)
(
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
recycle
d
)
recycle
)))
(
unintern
*
sym
package
))