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
16
Issues
16
List
Boards
Labels
Service Desk
Milestones
Merge Requests
8
Merge Requests
8
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
asdf
asdf
Commits
915661dd
Commit
915661dd
authored
Apr 04, 2020
by
Robert Goldman
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'local-nicknames' into 'master'
Closes
#14
See merge request
!127
parents
fc406ce1
85dedfeb
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
180 additions
and
8 deletions
+180
-8
package-inferred-system.lisp
package-inferred-system.lisp
+2
-2
test/package-inferred-system-test.script
test/package-inferred-system-test.script
+5
-2
test/test-package-local-nicknames.script
test/test-package-local-nicknames.script
+114
-0
uiop/common-lisp.lisp
uiop/common-lisp.lisp
+1
-0
uiop/package.lisp
uiop/package.lisp
+58
-4
No files found.
package-inferred-system.lisp
View file @
915661dd
...
@@ -75,9 +75,9 @@ the DEFPACKAGE-FORM uses it or imports a symbol from it."
...
@@ -75,9 +75,9 @@ the DEFPACKAGE-FORM uses it or imports a symbol from it."
(
dolist
(
p
arguments
)
(
dep
(
string
p
))))
(
dolist
(
p
arguments
)
(
dep
(
string
p
))))
((
:import-from
:shadowing-import-from
)
((
:import-from
:shadowing-import-from
)
(
dep
(
string
(
first
arguments
))))
(
dep
(
string
(
first
arguments
))))
#+
sbcl
#+
package-local-nicknames
((
:local-nicknames
)
((
:local-nicknames
)
(
loop*
:for
(
local-nickname
actual-package-name
)
:in
arguments
:do
(
loop*
:for
(
nil
actual-package-name
)
:in
arguments
:do
(
dep
(
string
actual-package-name
))))
(
dep
(
string
actual-package-name
))))
((
:nicknames
:documentation
:shadow
:export
:intern
:unintern
:recycle
)))))
((
:nicknames
:documentation
:shadow
:export
:intern
:unintern
:recycle
)))))
:from-end
t
:test
'equal
))
:from-end
t
:test
'equal
))
...
...
test/package-inferred-system-test.script
View file @
915661dd
...
@@ -17,8 +17,11 @@
...
@@ -17,8 +17,11 @@
;; package-inferred-system object.
;; package-inferred-system object.
(assert-equal "package-inferred-system-test" (primary-system-name (find-system :package-inferred-system-test/a/x)))
(assert-equal "package-inferred-system-test" (primary-system-name (find-system :package-inferred-system-test/a/x)))
;; Test that SBCL's :local-nicknames are recognized
;; Test that :local-nicknames are recognized on relevant implementations
#+sbcl
;; NB: requires ABCL >= ? (old 1.5.0 works), CCL >= 1.12 (unreleased as of Dec 2019),
;; CLASP >= ??? (no less released than anything else?), ECL >= 1.6.4 (unreleased as of Dec 2019),
;; SBCL >= ? (old 1.5.0 works)
#+package-local-nicknames
(progn
(progn
(load-system :package-inferred-system-test/local-nicknames-1)
(load-system :package-inferred-system-test/local-nicknames-1)
(assert-equal "g" (symbol-call :package-inferred-system-test/local-nicknames-1 :f)))
(assert-equal "g" (symbol-call :package-inferred-system-test/local-nicknames-1 :f)))
test/test-package-local-nicknames.script
0 → 100644
View file @
915661dd
;;; -*- mode:common-lisp; -*-
(
in-package
:asdf-test
)
;;; these tests for DEFINE-PACKAGE support of package-local-nicknames were adapted from
;;; the trivial-package-local-nicknames system, to test UIOP's support for package local
;;; nicknames
(
progn
(
defparameter
+test-data+
#+
sbcl
'
(
:sb-ext
:sb
:exit
)
#+
ccl
'
(
:ccl
:cc
:quit
)
#+
ecl
'
(
:ext
:ex
:exit
)
#+
abcl
'
(
:ext
:ex
:quit
)
#+
clasp
'
(
:core
:ex
:quit
)
#+
lispworks
'
(
:lispworks
:ex
:quit
)
#+
allegro
'
(
:excl
:ex
:exit
))
(
defparameter
+pkg-name+
(
first
+test-data+
))
(
defparameter
+nn-name+
(
second
+test-data+
))
(
defparameter
+sym-name+
(
third
+test-data+
))
(
defparameter
+pkg-sname+
(
string
+pkg-name+
))
(
defparameter
+nn-sname+
(
string
+nn-name+
))
(
defparameter
+sym-sname+
(
string
+sym-name+
))
(
defparameter
+sym-fullname+
(
concatenate
'string
+pkg-sname+
":"
+sym-sname+
))
(
defparameter
+sym-fullnickname+
(
concatenate
'string
+nn-sname+
":"
+sym-sname+
))
(
defparameter
+sym+
(
or
(
find-symbol
+sym-sname+
+pkg-name+
)
(
error
"Symbol not found while loading tests: check +SYM+ binding."
))))
(
defun
reset-test-packages
()
(
#+
sbcl
sb-ext:without-package-locks
#-
sbcl
progn
(
when
(
find-package
:package-local-nicknames-test-1
)
(
delete-package
:package-local-nicknames-test-1
))
(
when
(
find-package
:package-local-nicknames-test-2
)
(
delete-package
:package-local-nicknames-test-2
)))
(
let
((
form1
`
(
uiop/package:define-package
:package-local-nicknames-test-1
(
:use
)
(
:local-nicknames
(
:l
:cl
)
(
,
+nn-name+
,
+pkg-name+
)))))
(
eval
form1
))
(
let
((
form2
`
(
uiop/package:define-package
:package-local-nicknames-test-2
(
:use
)
(
:export
"CONS"
))))
(
eval
form2
)))
(
defmacro
define-test
(
name
&rest
body
)
`
(
progn
(
DBG
,
(
symbol-name
name
))
,@
body
))
(
define-test
test-package-local-nicknames-introspection
(
reset-test-packages
)
(
dolist
(
p
'
(
"KEYWORD"
"COMMON-LISP"
"COMMON-LISP-USER"
:package-local-nicknames-test-1
:package-local-nicknames-test-2
))
(
let
((
*package*
(
find-package
p
)))
(
let
((
alist
(
uiop/package:package-local-nicknames
:package-local-nicknames-test-1
)))
(
assert
(
equal
(
cons
"L"
(
find-package
"CL"
))
(
assoc
"L"
alist
:test
'string=
)))
(
assert
(
equal
(
cons
+nn-sname+
(
find-package
+pkg-sname+
))
(
assoc
+nn-sname+
alist
:test
'string=
)))
(
assert
(
eql
2
(
length
alist
)))))))
(
define-test
test-package-local-nicknames-symbol-equality
(
reset-test-packages
)
(
let
((
*package*
(
find-package
:package-local-nicknames-test-1
)))
(
let
((
cons0
(
read-from-string
"L:CONS"
))
(
cons1
(
find-symbol
"CONS"
:l
))
(
cons1s
(
find-symbol
"CONS"
#\L
))
(
exit0
(
read-from-string
+sym-fullname+
))
(
exit1
(
find-symbol
+sym-sname+
+nn-name+
)))
(
assert
(
eq
'cons
cons0
))
(
assert
(
eq
'cons
cons1
))
(
assert
(
eq
'cons
cons1s
))
(
assert
(
eq
+sym+
exit0
))
(
assert
(
eq
+sym+
exit1
)))))
(
define-test
test-package-local-nicknames-package-equality
(
reset-test-packages
)
(
let
((
*package*
(
find-package
:package-local-nicknames-test-1
)))
(
let
((
cl
(
find-package
:l
))
(
cls
(
find-package
#\L
))
(
sb
(
find-package
+nn-name+
)))
(
assert
(
eq
cl
(
find-package
:common-lisp
)))
(
assert
(
eq
cls
(
find-package
:common-lisp
)))
(
assert
(
eq
sb
(
find-package
+pkg-name+
))))))
(
define-test
test-package-local-nicknames-nickname-removal
(
reset-test-packages
)
(
assert
(
=
2
(
length
(
uiop/package:package-local-nicknames
:package-local-nicknames-test-1
))))
(
assert
(
uiop/package:remove-package-local-nickname
:l
:package-local-nicknames-test-1
))
(
assert
(
=
1
(
length
(
uiop/package:package-local-nicknames
:package-local-nicknames-test-1
))))
(
let
((
*package*
(
find-package
:package-local-nicknames-test-1
)))
(
assert
(
not
(
find-package
:l
)))))
(
define-test
test-package-local-nicknames-nickname-removal-char
#+
ignore
(
declare
(
optimize
(
debug
3
)
(
speed
0
)))
(
reset-test-packages
)
(
assert
(
=
2
(
length
(
uiop/package:package-local-nicknames
:package-local-nicknames-test-1
))))
(
assert
(
uiop/package:remove-package-local-nickname
#\L
:package-local-nicknames-test-1
))
(
assert
(
=
1
(
length
(
uiop/package:package-local-nicknames
:package-local-nicknames-test-1
))))
(
let
((
*package*
(
find-package
:package-local-nicknames-test-1
)))
(
assert
(
not
(
find-package
:l
)))))
(
define-test
test-package-local-nicknames-nickname-removal-readd-another-package-equality
(
reset-test-packages
)
(
assert
(
uiop/package:remove-package-local-nickname
:l
:package-local-nicknames-test-1
))
(
assert
(
eq
(
find-package
:package-local-nicknames-test-1
)
(
uiop/package:add-package-local-nickname
:l
:package-local-nicknames-test-2
:package-local-nicknames-test-1
)))
(
let
((
*package*
(
find-package
:package-local-nicknames-test-1
)))
(
let
((
cl
(
find-package
:l
))
(
sb
(
find-package
+nn-name+
)))
(
assert
(
eq
cl
(
find-package
:package-local-nicknames-test-2
)))
(
assert
(
eq
sb
(
find-package
+pkg-name+
))))))
uiop/common-lisp.lisp
View file @
915661dd
...
@@ -140,6 +140,7 @@
...
@@ -140,6 +140,7 @@
(
unless
(
member
:lispworks6
*features*
)
(
unless
(
member
:lispworks6
*features*
)
(
pushnew
:lispworks7+
*features*
)))))
(
pushnew
:lispworks7+
*features*
)))))
#.
(
or
#+
mcl
;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
#.
(
or
#+
mcl
;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
(
read-from-string
(
read-from-string
"(eval-when (:load-toplevel :compile-toplevel :execute)
"(eval-when (:load-toplevel :compile-toplevel :execute)
...
...
uiop/package.lisp
View file @
915661dd
...
@@ -4,6 +4,22 @@
...
@@ -4,6 +4,22 @@
;; See https://bugs.launchpad.net/asdf/+bug/485687
;; See https://bugs.launchpad.net/asdf/+bug/485687
;;
;;
;;; package local nicknames feature. Can't be deferred until common-lisp.lisp,
;;; where most such features are set.
;;; ABCL and CCL already define this feature appropriately.
;;; Seems to be unconditionally present for SBCL, ACL, and clasp
;;; Don't know about ecl, or others
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
;; abcl pushes :package-local-nicknames without UIOP interfering,
;; and Lispworks will do so
#+
(
or
sbcl
clasp
)
(
pushnew
:package-local-nicknames
*features*
)
#+
allegro
(
let
((
fname
(
find-symbol
(
symbol-name
'
#:add-package-local-nickname
)
'
#:excl
)))
(
when
(
and
fname
(
fboundp
fname
))
(
pushnew
:package-local-nicknames
*features*
))))
(
defpackage
:uiop/package
(
defpackage
:uiop/package
;; CAUTION: we must handle the first few packages specially for hot-upgrade.
;; CAUTION: we must handle the first few packages specially for hot-upgrade.
;; This package definition MUST NOT change unless its name too changes;
;; This package definition MUST NOT change unless its name too changes;
...
@@ -12,6 +28,15 @@
...
@@ -12,6 +28,15 @@
;; import and export the same exact symbols as for ASDF 2.27.
;; import and export the same exact symbols as for ASDF 2.27.
;; Any other symbol must be import-from'ed and re-export'ed in a different package.
;; Any other symbol must be import-from'ed and re-export'ed in a different package.
(
:use
:common-lisp
)
(
:use
:common-lisp
)
#+
package-local-nicknames
(
:import-from
#+
allegro
#:excl
#+
sbcl
#:sb-ext
#+
(
or
clasp
abcl
)
#:ext
#+
ccl
#:ccl
#+
lispworks
#:hcl
#-
(
or
allegro
sbcl
clasp
abcl
ccl
lispworks
)
(
error
"Don't know from which package this lisp supplies the local-package-nicknames API."
)
#:remove-package-local-nickname
#:package-local-nicknames
#:add-package-local-nickname
)
(
:export
(
:export
#:find-package*
#:find-symbol*
#:symbol-call
#:find-package*
#:find-symbol*
#:symbol-call
#:intern*
#:export*
#:import*
#:shadowing-import*
#:shadow*
#:make-symbol*
#:unintern*
#:intern*
#:export*
#:import*
#:shadowing-import*
#:shadow*
#:make-symbol*
#:unintern*
...
@@ -22,7 +47,11 @@
...
@@ -22,7 +47,11 @@
#:ensure-package-unused
#:delete-package*
#:ensure-package-unused
#:delete-package*
#:package-names
#:packages-from-names
#:fresh-package-name
#:rename-package-away
#:package-names
#:packages-from-names
#:fresh-package-name
#:rename-package-away
#:package-definition-form
#:parse-define-package-form
#:package-definition-form
#:parse-define-package-form
#:ensure-package
#:define-package
))
#:ensure-package
#:define-package
#+
package-local-nicknames
#:add-package-local-nickname
#+
package-local-nicknames
#:remove-package-local-nickname
#+
package-local-nicknames
#:package-local-nicknames
))
(
in-package
:uiop/package
)
(
in-package
:uiop/package
)
...
@@ -572,12 +601,13 @@ or when loading the package is optional."
...
@@ -572,12 +601,13 @@ or when loading the package is optional."
(
multiple-value-bind
(
symbol
status
)
(
find-symbol*
name
from-package
)
(
multiple-value-bind
(
symbol
status
)
(
find-symbol*
name
from-package
)
(
unless
(
eq
status
:external
)
(
unless
(
eq
status
:external
)
(
ensure-exported
name
symbol
from-package
recycle
))))
(
ensure-exported
name
symbol
from-package
recycle
))))
(
defun
ensure-package
(
name
&key
(
defun
ensure-package
(
name
&key
nicknames
documentation
use
nicknames
documentation
use
shadow
shadowing-import-from
shadow
shadowing-import-from
import-from
export
intern
import-from
export
intern
recycle
mix
reexport
recycle
mix
reexport
unintern
)
unintern
local-nicknames
)
#+
genera
(
declare
(
ignore
documentation
))
#+
genera
(
declare
(
ignore
documentation
))
(
let*
((
package-name
(
string
name
))
(
let*
((
package-name
(
string
name
))
(
nicknames
(
mapcar
#'
string
nicknames
))
(
nicknames
(
mapcar
#'
string
nicknames
))
...
@@ -594,11 +624,13 @@ or when loading the package is optional."
...
@@ -594,11 +624,13 @@ or when loading the package is optional."
(
export
(
mapcar
'string
export
))
(
export
(
mapcar
'string
export
))
(
intern
(
mapcar
'string
intern
))
(
intern
(
mapcar
'string
intern
))
(
unintern
(
mapcar
'string
unintern
))
(
unintern
(
mapcar
'string
unintern
))
(
local-nicknames
(
mapcar
#'
(
lambda
(
pair
)
(
mapcar
'string
pair
))
local-nicknames
))
(
shadowed
(
make-hash-table
:test
'equal
))
; string to bool
(
shadowed
(
make-hash-table
:test
'equal
))
; string to bool
(
imported
(
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
(
exported
(
make-hash-table
:test
'equal
))
; string to bool
;; string to list home package and use package:
;; string to list home package and use package:
(
inherited
(
make-hash-table
:test
'equal
)))
(
inherited
(
make-hash-table
:test
'equal
)))
(
declare
(
ignorable
local-nicknames
))
; if not supported
(
when-package-fishiness
(
record-fishy
package-name
))
(
when-package-fishiness
(
record-fishy
package-name
))
#-
genera
#-
genera
(
when
documentation
(
setf
(
documentation
package
t
)
documentation
))
(
when
documentation
(
setf
(
documentation
package
t
)
documentation
))
...
@@ -613,6 +645,15 @@ or when loading the package is optional."
...
@@ -613,6 +645,15 @@ or when loading the package is optional."
(
t
(
rename-package-away
p
)
(
t
(
rename-package-away
p
)
(
push
p
to-delete
))))
(
push
p
to-delete
))))
(
rename-package
package
package-name
nicknames
)
(
rename-package
package
package-name
nicknames
)
;; Handle local nicknames
#+
package-local-nicknames
(
let*
((
existing-nicknames
(
mapcar
#'
(
lambda
(
x
)
(
string
(
car
x
)))
(
package-local-nicknames
package
)))
(
new-nicknames
(
mapcar
#'
(
lambda
(
x
)
(
string
(
first
x
)))
local-nicknames
))
(
to-remove
(
set-difference
existing-nicknames
new-nicknames
:test
'equal
)))
(
mapc
#'
(
lambda
(
x
)
(
remove-package-local-nickname
x
package
))
to-remove
))
#+
package-local-nicknames
(
loop
:for
(
nick-str
package-str
)
:in
local-nicknames
:do
(
add-package-local-nickname
nick-str
package-str
package
))
(
dolist
(
name
unintern
)
(
dolist
(
name
unintern
)
(
multiple-value-bind
(
existing
status
)
(
find-symbol
name
package
)
(
multiple-value-bind
(
existing
status
)
(
find-symbol
name
package
)
(
when
status
(
when
status
...
@@ -673,6 +714,7 @@ or when loading the package is optional."
...
@@ -673,6 +714,7 @@ or when loading the package is optional."
(
map
()
'delete-package*
to-delete
)
(
map
()
'delete-package*
to-delete
)
package
)))
package
)))
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
(
defun
parse-define-package-form
(
package
clauses
)
(
defun
parse-define-package-form
(
package
clauses
)
(
loop
(
loop
...
@@ -699,6 +741,13 @@ or when loading the package is optional."
...
@@ -699,6 +741,13 @@ or when loading the package is optional."
:when
(
eq
kw
:mix-reexport
)
:append
args
:into
mix
:and
:append
args
:into
reexport
:when
(
eq
kw
:mix-reexport
)
:append
args
:into
mix
:and
:append
args
:into
reexport
:and
:do
(
setf
use-p
t
)
:else
:and
:do
(
setf
use-p
t
)
:else
:when
(
eq
kw
:unintern
)
:append
args
:into
unintern
:else
:when
(
eq
kw
:unintern
)
:append
args
:into
unintern
:else
:when
(
eq
kw
:local-nicknames
)
:if
(
symbol-call
'
#:uiop
'
#:featurep
:package-local-nicknames
)
:append
args
:into
local-nicknames
:else
:do
(
error
":LOCAL-NICKAMES option is not supported on this lisp implementation."
)
:end
:else
:do
(
error
"unrecognized define-package keyword ~S"
kw
)
:do
(
error
"unrecognized define-package keyword ~S"
kw
)
:finally
(
return
`
(
',package
:finally
(
return
`
(
',package
:nicknames
',nicknames
:documentation
',documentation
:nicknames
',nicknames
:documentation
',documentation
...
@@ -706,7 +755,8 @@ or when loading the package is optional."
...
@@ -706,7 +755,8 @@ or when loading the package is optional."
:shadow
',shadow
:shadowing-import-from
',shadowing-import-from
:shadow
',shadow
:shadowing-import-from
',shadowing-import-from
:import-from
',import-from
:export
',export
:intern
',intern
:import-from
',import-from
:export
',export
:intern
',intern
:recycle
',
(
if
recycle-p
recycle
(
cons
package
nicknames
))
:recycle
',
(
if
recycle-p
recycle
(
cons
package
nicknames
))
:mix
',mix
:reexport
',reexport
:unintern
',unintern
)))))
:mix
',mix
:reexport
',reexport
:unintern
',unintern
:local-nicknames
',local-nicknames
)))))
(
defmacro
define-package
(
package
&rest
clauses
)
(
defmacro
define-package
(
package
&rest
clauses
)
"DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
"DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
...
@@ -730,7 +780,11 @@ an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
...
@@ -730,7 +780,11 @@ an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
REEXPORT -- Takes a list of package designators. For each package, p, in the list,
REEXPORT -- Takes a list of package designators. For each package, p, in the list,
export symbols with the same name as those exported from p. Note that in the case
export symbols with the same name as those exported from p. Note that in the case
of shadowing, etc. the symbols with the same name may not be the same symbols.
of shadowing, etc. the symbols with the same name may not be the same symbols.
UNINTERN -- Remove symbols here from PACKAGE."
UNINTERN -- Remove symbols here from PACKAGE.
LOCAL-NICKNAMES -- If the host implementation supports package local nicknames
\(check for the :PACKAGE-LOCAL-NICKNAMES feature\), then this should be a list of
nickname and package name pairs. Using this option will cause an error if the
host CL implementation does not support it."
(
let
((
ensure-form
(
let
((
ensure-form
`
(
prog1
`
(
prog1
(
funcall
'ensure-package
,@
(
parse-define-package-form
package
clauses
))
(
funcall
'ensure-package
,@
(
parse-define-package-form
package
clauses
))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment