Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
A
asdf
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Pascal J. Bourguignon
asdf
Commits
a5eda299
Commit
a5eda299
authored
14 years ago
by
Francois-Rene Rideau
Browse files
Options
Downloads
Patches
Plain Diff
2.130: be nicer with packages, fallback, shortcuts, missing SBCL_HOME, etc.
parent
abb3b005
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
asdf.lisp
+46
-47
46 additions, 47 deletions
asdf.lisp
with
46 additions
and
47 deletions
asdf.lisp
+
46
−
47
View file @
a5eda299
...
...
@@ -47,7 +47,7 @@
#+
xcvb
(
module
())
(
cl:in-package
:cl
)
(
cl:in-package
:cl
-user
)
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
;;; make package if it doesn't exist yet.
...
...
@@ -55,7 +55,7 @@
(
unless
(
find-package
:asdf
)
(
make-package
:asdf
:use
'
(
:cl
)))
;;; Implementation-dependent tweaks
;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
;; (declaim (optimize (speed 2) (debug 2) (safety 3))
)
; NO: rely on the implementation defaults.
#+
allegro
(
setf
excl::*autoload-package-name-alist*
(
remove
"asdf"
excl::*autoload-package-name-alist*
...
...
@@ -72,7 +72,7 @@
(
defvar
*asdf-version*
nil
)
(
defvar
*upgraded-p*
nil
)
(
let*
((
asdf-version
;; the 1+ helps the version bumping script discriminate
(
subseq
"VERSION:2.1
29
"
(
1+
(
length
"VERSION"
))))
(
subseq
"VERSION:2.1
30
"
(
1+
(
length
"VERSION"
))))
(
existing-asdf
(
fboundp
'find-system
))
(
existing-version
*asdf-version*
)
(
already-there
(
equal
asdf-version
existing-version
)))
...
...
@@ -82,36 +82,30 @@
"~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
existing-version
asdf-version
))
(
labels
((
rename-away
(
package
)
(
loop
:with
name
=
(
package-name
package
)
:for
i
:from
1
:for
new
=
(
format
nil
"~A.~D"
name
i
)
:unless
(
find-package
new
)
:do
(
rename-package-name
package
name
new
)))
(
rename-package-name
(
package
old
new
)
(
let*
((
old-names
(
cons
(
package-name
package
)
(
package-nicknames
package
)))
(
new-names
(
subst
new
old
old-names
:test
'equal
))
(
new-name
(
car
new-names
))
(
new-nicknames
(
cdr
new-names
)))
(
rename-package
package
new-name
new-nicknames
)))
((
unlink-package
(
package
)
(
let
((
u
(
find-package
package
)))
(
when
u
(
ensure-unintern
u
(
loop
:for
s
:being
:each
:present-symbol
:in
u
:collect
s
))
(
loop
:for
p
:in
(
package-used-by-list
u
)
:do
(
unuse-package
u
p
))
(
delete-package
u
))))
(
ensure-exists
(
name
nicknames
use
)
(
let*
((
previous
(
remove-duplicates
(
remove-if
#'
null
(
mapcar
#'
find-package
(
cons
name
nicknames
)))
:from-end
t
)))
(
cond
(
previous
;; do away with packages with conflicting (nick)names
(
map
()
#'
rename-away
(
cdr
previous
))
;; reuse previous package with same name
(
let
((
p
(
car
previous
)))
(
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-use
p
use
)
p
)
)
(
t
(
make-package
name
:nicknames
nicknames
:use
use
)))))
p
)
(
t
(
make-package
name
:nicknames
nicknames
:use
use
)))))
)
(
find-sym
(
symbol
package
)
(
find-symbol
(
string
symbol
)
package
))
(
intern*
(
symbol
package
)
...
...
@@ -176,9 +170,7 @@
:shadow
',shadow
:unintern
',
(
append
#-
(
or
gcl
ecl
)
redefined-functions
unintern
)
:fmakunbound
',
(
append
fmakunbound
))))
(
let
((
u
(
find-package
:asdf-utilities
)))
(
when
u
(
ensure-unintern
u
(
loop
:for
s
:being
:each
:present-symbol
:in
u
:collect
s
))))
(
unlink-package
:asdf-utilities
)
(
pkgdcl
:asdf
:use
(
:common-lisp
)
...
...
@@ -334,7 +326,7 @@
'
(
defmethod
update-instance-for-redefined-class
:after
((
m
module
)
added
deleted
plist
&key
)
(
declare
(
ignorable
deleted
plist
))
(
format
*trace-output*
"Updating ~A~%"
m
)
(
when
*asdf-verbose*
(
format
*trace-output*
"Updating ~A~%"
m
)
)
(
when
(
member
'components-by-name
added
)
(
compute-module-components-by-name
m
))))))
...
...
@@ -1288,17 +1280,22 @@ to ~S which is not a directory.~@:>"
(
setf
(
gethash
(
coerce-name
name
)
*defined-systems*
)
(
cons
(
get-universal-time
)
system
)))
(
defun*
sysdef-find-asdf
(
system
)
(
let
((
name
(
coerce-name
system
)))
(
when
(
equal
name
"asdf"
)
(
let*
((
registered
(
cdr
(
gethash
name
*defined-systems*
)))
(
asdf
(
or
registered
(
defun*
find-system-fallback
(
requested
fallback
&optional
source-file
)
(
setf
fallback
(
coerce-name
fallback
)
source-file
(
or
source-file
*compile-file-truename*
*load-truename*
)
requested
(
coerce-name
requested
))
(
when
(
equal
requested
fallback
)
(
let*
((
registered
(
cdr
(
gethash
fallback
*defined-systems*
)))
(
system
(
or
registered
(
make-instance
'system
:name
"asdf"
:source-file
(
or
*compile-file-truename*
*load-truename*
)))))
(
unless
registered
(
register-system
"asdf"
asdf
))
(
throw
'find-system
asdf
)))))
'system
:name
fallback
:source-file
source-file
))))
(
unless
registered
(
register-system
fallback
system
))
(
throw
'find-system
system
))))
(
defun*
sysdef-find-asdf
(
name
)
(
find-system-fallback
name
"asdf"
))
;;;; -------------------------------------------------------------------------
...
...
@@ -2775,7 +2772,7 @@ with a different configuration, so the configuration would be re-read then."
(
unless
(
or
(
member
directive
'
(
:inherit-configuration
:ignore-inherited-configuration
:enable-user-cache
:disable-cache
))
:enable-user-cache
:disable-cache
nil
))
(
and
(
consp
directive
)
(
or
(
and
(
length=n-p
directive
2
)
(
or
(
and
(
eq
(
first
directive
)
:include
)
...
...
@@ -2920,7 +2917,7 @@ with a different configuration, so the configuration would be re-read then."
(
process-output-translations-directive
'
(
t
t
)
:collect
collect
))
((
:inherit-configuration
)
(
inherit-output-translations
inherit
:collect
collect
))
((
:ignore-inherited-configuration
)
((
:ignore-inherited-configuration
nil
)
nil
))
(
let
((
src
(
first
directive
))
(
dst
(
second
directive
)))
...
...
@@ -3116,6 +3113,8 @@ effectively disabling the output translation facility."
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
#+
(
and
(
or
win32
windows
mswindows
mingw32
)
(
not
cygwin
)
(
not
clisp
))
(
progn
(
defparameter
*link-initial-dword*
76
)
(
defparameter
*link-guid*
#(
1
20
2
0
0
0
0
0
192
0
0
0
0
0
0
70
))
...
...
@@ -3182,7 +3181,7 @@ effectively disabling the output translation facility."
(
read-sequence
buffer
s
)
(
map
'string
#'
code-char
buffer
)))))))
(
end-of-file
()
nil
))))
nil
))))
)
;;;; -----------------------------------------------------------------
;;;; Source Registry Configuration, by Francois-Rene Rideau
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment