Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Eric Timmons
asdf
Commits
0a6a0e77
Commit
0a6a0e77
authored
May 02, 2021
by
Robert Goldman
Browse files
Merge branch 'master' into 'master'
Two more changes for Genera See merge request
asdf/asdf!172
parents
6e2df328
d6d7d423
Changes
13
Hide whitespace changes
Inline
Side-by-side
bundle.lisp
View file @
0a6a0e77
...
...
@@ -556,7 +556,7 @@ which is probably not what you want; you probably need to tweak your output tran
(
defmethod
component-depends-on
:around
((
o
image-op
)
(
c
system
))
(
let*
((
next
(
call-next-method
))
(
deps
(
make-hash-table
:test
'equal
))
(
linkable
(
loop
*
:for
(
do
.
dcs
)
:in
next
:collect
(
linkable
(
loop
:for
(
do
.
dcs
)
:in
next
:collect
(
cons
do
(
loop
:for
dc
:in
dcs
:for
dep
=
(
and
dc
(
resolve-dependency-spec
c
dc
))
...
...
find-system.lisp
View file @
0a6a0e77
...
...
@@ -68,7 +68,7 @@
(
defmethod
component-depends-on
((
o
define-op
)
(
s
system
))
`
(
;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below.
;; 2- We don't call-next-method to avoid other methods
,@
(
loop
*
:for
(
o
.
c
)
:in
(
definition-dependency-list
s
)
:collect
(
list
o
c
))))
,@
(
loop
:for
(
o
.
c
)
:in
(
definition-dependency-list
s
)
:collect
(
list
o
c
))))
(
defmethod
component-depends-on
((
o
operation
)
(
s
system
))
`
(
,@
(
when
(
and
(
not
(
typep
o
'define-op
))
...
...
header.lisp
View file @
0a6a0e77
;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ;
Package: CL-USER ;
buffer-read-only: t; -*-
;;; This is ASDF 3.3.4.14: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
...
...
output-translations.lisp
View file @
0a6a0e77
...
...
@@ -293,19 +293,19 @@ effectively disabling the output translation facility."
path
)
((
or
pathname
string
)
(
ensure-output-translations
)
(
loop
*
:with
p
=
(
resolve-symlinks*
path
)
:for
(
source
destination
)
:in
(
car
*output-translations*
)
:for
root
=
(
when
(
or
(
eq
source
t
)
(
and
(
pathnamep
source
)
(
not
(
absolute-pathname-p
source
))))
(
pathname-root
p
))
:for
absolute-source
=
(
cond
((
eq
source
t
)
(
wilden
root
))
(
root
(
merge-pathnames*
source
root
))
(
t
source
))
:when
(
or
(
eq
source
t
)
(
pathname-match-p
p
absolute-source
))
:return
(
translate-pathname*
p
absolute-source
destination
root
source
)
:finally
(
return
p
)))))
(
loop
:with
p
=
(
resolve-symlinks*
path
)
:for
(
source
destination
)
:in
(
car
*output-translations*
)
:for
root
=
(
when
(
or
(
eq
source
t
)
(
and
(
pathnamep
source
)
(
not
(
absolute-pathname-p
source
))))
(
pathname-root
p
))
:for
absolute-source
=
(
cond
((
eq
source
t
)
(
wilden
root
))
(
root
(
merge-pathnames*
source
root
))
(
t
source
))
:when
(
or
(
eq
source
t
)
(
pathname-match-p
p
absolute-source
))
:return
(
translate-pathname*
p
absolute-source
destination
root
source
)
:finally
(
return
p
)))))
;; Hook into uiop's output-translation mechanism
...
...
package-inferred-system.lisp
View file @
0a6a0e77
...
...
@@ -69,17 +69,17 @@ the DEFPACKAGE-FORM uses it or imports a symbol from it."
(
assert
(
defpackage-form-p
defpackage-form
))
(
remove-duplicates
(
while-collecting
(
dep
)
(
loop
*
:for
(
option
.
arguments
)
:in
(
cddr
defpackage-form
)
:do
(
ecase
option
((
:use
:mix
:reexport
:use-reexport
:mix-reexport
)
(
dolist
(
p
arguments
)
(
dep
(
string
p
))))
((
:import-from
:shadowing-import-from
)
(
dep
(
string
(
first
arguments
))))
#+
package-local-nicknames
((
:local-nicknames
)
(
loop
*
:for
(
nil
actual-package-name
)
:in
arguments
:do
(
dep
(
string
actual-package-name
))))
((
:nicknames
:documentation
:shadow
:export
:intern
:unintern
:recycle
)))))
(
loop
:for
(
option
.
arguments
)
:in
(
cddr
defpackage-form
)
:do
(
ecase
option
((
:use
:mix
:reexport
:use-reexport
:mix-reexport
)
(
dolist
(
p
arguments
)
(
dep
(
string
p
))))
((
:import-from
:shadowing-import-from
)
(
dep
(
string
(
first
arguments
))))
#+
package-local-nicknames
((
:local-nicknames
)
(
loop
:for
(
nil
actual-package-name
)
:in
arguments
:do
(
dep
(
string
actual-package-name
))))
((
:nicknames
:documentation
:shadow
:export
:intern
:unintern
:recycle
)))))
:from-end
t
:test
'equal
))
(
defun
package-designator-name
(
package
)
...
...
parse-defsystem.lisp
View file @
0a6a0e77
...
...
@@ -195,44 +195,44 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~
(
defun
%define-component-inline-methods
(
ret
rest
)
;; find key-value pairs that look like inline method definitions in REST. For each identified
;; definition, parse it and, if it is well-formed, define the method.
(
loop
*
:for
(
key
value
)
:on
rest
:by
#'
cddr
:for
name
=
(
and
(
keywordp
key
)
(
find
key
+asdf-methods+
:test
'string=
))
:when
name
:do
;; parse VALUE as an inline method definition of the form
;;
;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
(
destructuring-bind
(
operation-name
&rest
rest
)
value
(
let
((
qualifiers
'
()))
;; ensure that OPERATION-NAME is a symbol.
(
unless
(
and
(
symbolp
operation-name
)
(
not
(
null
operation-name
)))
(
sysdef-error
"Ill-formed inline method: ~S. The first element is not a symbol ~
(
loop
:for
(
key
value
)
:on
rest
:by
#'
cddr
:for
name
=
(
and
(
keywordp
key
)
(
find
key
+asdf-methods+
:test
'string=
))
:when
name
:do
;; parse VALUE as an inline method definition of the form
;;
;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
(
destructuring-bind
(
operation-name
&rest
rest
)
value
(
let
((
qualifiers
'
()))
;; ensure that OPERATION-NAME is a symbol.
(
unless
(
and
(
symbolp
operation-name
)
(
not
(
null
operation-name
)))
(
sysdef-error
"Ill-formed inline method: ~S. The first element is not a symbol ~
designating an operation but ~S."
value
operation-name
))
;; ensure that REST starts with either a cons (potential lambda list, further checked
;; below) or a qualifier accepted by the standard method combination. Everything else
;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
;; has to start with the lambda list.
(
cond
((
consp
(
car
rest
)))
((
not
(
member
(
car
rest
)
*standard-method-combination-qualifiers*
))
(
sysdef-error
"Ill-formed inline method: ~S. Only a single of the standard ~
value
operation-name
))
;; ensure that REST starts with either a cons (potential lambda list, further checked
;; below) or a qualifier accepted by the standard method combination. Everything else
;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
;; has to start with the lambda list.
(
cond
((
consp
(
car
rest
)))
((
not
(
member
(
car
rest
)
*standard-method-combination-qualifiers*
))
(
sysdef-error
"Ill-formed inline method: ~S. Only a single of the standard ~
qualifiers ~{~S~^ ~} is allowed, not ~S."
value
*standard-method-combination-qualifiers*
(
car
rest
)))
(
t
(
setf
qualifiers
(
list
(
pop
rest
)))))
;; REST must start with a two-element lambda list.
(
unless
(
and
(
listp
(
car
rest
))
(
length=n-p
(
car
rest
)
2
)
(
null
(
cddar
rest
)))
(
sysdef-error
"Ill-formed inline method: ~S. The operation name ~S is not followed by ~
value
*standard-method-combination-qualifiers*
(
car
rest
)))
(
t
(
setf
qualifiers
(
list
(
pop
rest
)))))
;; REST must start with a two-element lambda list.
(
unless
(
and
(
listp
(
car
rest
))
(
length=n-p
(
car
rest
)
2
)
(
null
(
cddar
rest
)))
(
sysdef-error
"Ill-formed inline method: ~S. The operation name ~S is not followed by ~
a lambda-list of the form (OPERATION COMPONENT) and a method body."
value
operation-name
))
;; define the method.
(
destructuring-bind
((
o
c
)
&rest
body
)
rest
(
pushnew
(
eval
`
(
defmethod
,
name
,@
qualifiers
((
,
o
,
operation-name
)
(
,
c
(
eql
,
ret
)))
,@
body
))
(
component-inline-methods
ret
)))))))
value
operation-name
))
;; define the method.
(
destructuring-bind
((
o
c
)
&rest
body
)
rest
(
pushnew
(
eval
`
(
defmethod
,
name
,@
qualifiers
((
,
o
,
operation-name
)
(
,
c
(
eql
,
ret
)))
,@
body
))
(
component-inline-methods
ret
)))))))
(
defun
%refresh-component-inline-methods
(
component
rest
)
;; clear methods, then add the new ones
...
...
plan.lisp
View file @
0a6a0e77
...
...
@@ -220,13 +220,13 @@ to be meaningful, or could it just as well have been done in another Lisp image?
(
with-upgradability
()
(
defun*
(
map-direct-dependencies
)
(
operation
component
fun
)
"Call FUN on all the valid dependencies of the given action in the given plan"
(
loop
*
:for
(
dep-o-spec
.
dep-c-specs
)
:in
(
component-depends-on
operation
component
)
:for
dep-o
=
(
find-operation
operation
dep-o-spec
)
:when
dep-o
:do
(
loop
:for
dep-c-spec
:in
dep-c-specs
:for
dep-c
=
(
and
dep-c-spec
(
resolve-dependency-spec
component
dep-c-spec
))
:when
(
action-valid-p
dep-o
dep-c
)
:do
(
funcall
fun
dep-o
dep-c
))))
(
loop
:for
(
dep-o-spec
.
dep-c-specs
)
:in
(
component-depends-on
operation
component
)
:for
dep-o
=
(
find-operation
operation
dep-o-spec
)
:when
dep-o
:do
(
loop
:for
dep-c-spec
:in
dep-c-specs
:for
dep-c
=
(
and
dep-c-spec
(
resolve-dependency-spec
component
dep-c-spec
))
:when
(
action-valid-p
dep-o
dep-c
)
:do
(
funcall
fun
dep-o
dep-c
))))
(
defun*
(
reduce-direct-dependencies
)
(
operation
component
combinator
seed
)
"Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
...
...
uiop/common-lisp.lisp
View file @
0a6a0e77
...
...
@@ -166,13 +166,6 @@
(
setq
clos::*redefine-class-in-place*
t
))
;; Make sure we have strict ANSI class redefinition semantics
;;;; Looping
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
(
defmacro
loop*
(
&rest
rest
)
#-
genera
`
(
loop
,@
rest
)
#+
genera
`
(
lisp:loop
,@
rest
)))
;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
;;;; compatfmt: avoid fancy format directives when unsupported
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
(
defun
frob-substrings
(
string
substrings
&optional
frob
)
...
...
uiop/configuration.lisp
View file @
0a6a0e77
...
...
@@ -218,21 +218,21 @@ directive.")
(
defun*
(
resolve-location
)
(
x
&key
ensure-directory
wilden
directory
)
"Resolve location designator X into a PATHNAME"
;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
(
loop
*
:with
dirp
=
(
or
directory
ensure-directory
)
:with
(
first
.
rest
)
=
(
if
(
atom
x
)
(
list
x
)
x
)
:with
path
=
(
or
(
resolve-absolute-location
first
:ensure-directory
(
and
(
or
dirp
rest
)
t
)
:wilden
(
and
wilden
(
null
rest
)))
(
return
nil
))
:for
(
element
.
morep
)
:on
rest
:for
dir
=
(
and
(
or
morep
dirp
)
t
)
:for
wild
=
(
and
wilden
(
not
morep
))
:for
sub
=
(
merge-pathnames*
(
resolve-relative-location
element
:ensure-directory
dir
:wilden
wild
)
path
)
:do
(
setf
path
(
if
(
absolute-pathname-p
sub
)
(
resolve-symlinks*
sub
)
sub
))
:finally
(
return
path
)))
(
loop
:with
dirp
=
(
or
directory
ensure-directory
)
:with
(
first
.
rest
)
=
(
if
(
atom
x
)
(
list
x
)
x
)
:with
path
=
(
or
(
resolve-absolute-location
first
:ensure-directory
(
and
(
or
dirp
rest
)
t
)
:wilden
(
and
wilden
(
null
rest
)))
(
return
nil
))
:for
(
element
.
morep
)
:on
rest
:for
dir
=
(
and
(
or
morep
dirp
)
t
)
:for
wild
=
(
and
wilden
(
not
morep
))
:for
sub
=
(
merge-pathnames*
(
resolve-relative-location
element
:ensure-directory
dir
:wilden
wild
)
path
)
:do
(
setf
path
(
if
(
absolute-pathname-p
sub
)
(
resolve-symlinks*
sub
)
sub
))
:finally
(
return
path
)))
(
defun
location-designator-p
(
x
)
"Is X a designator for a location?"
...
...
uiop/os.lisp
View file @
0a6a0e77
...
...
@@ -66,22 +66,22 @@ keywords explicitly."
(
defun
detect-os
()
"Detects the current operating system. Only needs be run at compile-time,
except on ABCL where it might change between FASL compilation and runtime."
(
loop
*
:with
o
:for
(
feature
.
detect
)
:in
'
((
:os-unix
.
os-unix-p
)
(
:os-macosx
.
os-macosx-p
)
(
:os-windows
.
os-windows-p
)
(
:os-genera
.
os-genera-p
)
(
:os-oldmac
.
os-oldmac-p
)
(
:os-haiku
.
os-haiku-p
)
(
:os-mezzano
.
os-mezzano-p
))
:when
(
and
(
or
(
not
o
)
(
eq
feature
:os-macosx
)
(
eq
feature
:os-haiku
))
(
funcall
detect
))
:do
(
setf
o
feature
)
(
pushnew
feature
*features*
)
:else
:do
(
setf
*features*
(
remove
feature
*features*
))
:finally
(
return
(
or
o
(
error
"Congratulations for trying ASDF on an operating system~%~
(
loop
:with
o
:for
(
feature
.
detect
)
:in
'
((
:os-unix
.
os-unix-p
)
(
:os-macosx
.
os-macosx-p
)
(
:os-windows
.
os-windows-p
)
(
:os-genera
.
os-genera-p
)
(
:os-oldmac
.
os-oldmac-p
)
(
:os-haiku
.
os-haiku-p
)
(
:os-mezzano
.
os-mezzano-p
))
:when
(
and
(
or
(
not
o
)
(
eq
feature
:os-macosx
)
(
eq
feature
:os-haiku
))
(
funcall
detect
))
:do
(
setf
o
feature
)
(
pushnew
feature
*features*
)
:else
:do
(
setf
*features*
(
remove
feature
*features*
))
:finally
(
return
(
or
o
(
error
"Congratulations for trying ASDF on an operating system~%~
that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it."
)))))
(
defmacro
os-cond
(
&rest
clauses
)
#+
abcl
`
(
cond
,@
clauses
)
#-
abcl
(
loop
*
:for
(
test
.
body
)
:in
clauses
:when
(
eval
test
)
:return
`
(
progn
,@
body
)))
#-
abcl
(
loop
:for
(
test
.
body
)
:in
clauses
:when
(
eval
test
)
:return
`
(
progn
,@
body
)))
(
detect-os
))
...
...
uiop/stream.lisp
View file @
0a6a0e77
...
...
@@ -352,13 +352,13 @@ If LINEWISE is true, then read and copy the stream line by line, with an optiona
Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
(
with-open-stream
(
input
input
)
(
if
linewise
(
loop
*
:for
(
line
eof
)
=
(
multiple-value-list
(
read-line
input
nil
nil
))
:while
line
:do
(
when
prefix
(
princ
prefix
output
))
(
princ
line
output
)
(
unless
eof
(
terpri
output
))
(
finish-output
output
)
(
when
eof
(
return
)))
(
loop
:for
(
line
eof
)
=
(
multiple-value-list
(
read-line
input
nil
nil
))
:while
line
:do
(
when
prefix
(
princ
prefix
output
))
(
princ
line
output
)
(
unless
eof
(
terpri
output
))
(
finish-output
output
)
(
when
eof
(
return
)))
(
loop
:with
buffer-size
=
(
or
buffer-size
8192
)
:with
buffer
=
(
make-array
(
list
buffer-size
)
:element-type
(
or
element-type
'character
))
...
...
uiop/utility.lisp
View file @
0a6a0e77
...
...
@@ -4,9 +4,9 @@
(
uiop/package:define-package
:uiop/utility
(
:use
:uiop/common-lisp
:uiop/package
)
;; import and reexport a few things defined in :uiop/common-lisp
(
:import-from
:uiop/common-lisp
#:compatfmt
#:loop*
#:frob-substrings
(
:import-from
:uiop/common-lisp
#:compatfmt
#:frob-substrings
#+
(
or
clasp
ecl
)
#:use-ecl-byte-compiler-p
#+
mcl
#:probe-posix
)
(
:export
#:compatfmt
#:loop*
#:frob-substrings
#:compatfmt
(
:export
#:compatfmt
#:frob-substrings
#:compatfmt
#+
(
or
clasp
ecl
)
#:use-ecl-byte-compiler-p
#+
mcl
#:probe-posix
)
(
:export
;; magic helper to define debugging functions:
...
...
@@ -185,15 +185,15 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(
with-upgradability
()
(
defun
remove-plist-key
(
key
plist
)
"Remove a single key from a plist"
(
loop
*
:for
(
k
v
)
:on
plist
:by
#'
cddr
:unless
(
eq
k
key
)
:append
(
list
k
v
)))
(
loop
:for
(
k
v
)
:on
plist
:by
#'
cddr
:unless
(
eq
k
key
)
:append
(
list
k
v
)))
(
defun
remove-plist-keys
(
keys
plist
)
"Remove a list of keys from a plist"
(
loop
*
:for
(
k
v
)
:on
plist
:by
#'
cddr
:unless
(
member
k
keys
)
:append
(
list
k
v
))))
(
loop
:for
(
k
v
)
:on
plist
:by
#'
cddr
:unless
(
member
k
keys
)
:append
(
list
k
v
))))
;;; Sequences
...
...
@@ -209,17 +209,17 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;; NB: We assume a total order on character types.
;; If that's not true... this code will need to be updated.
(
defparameter
+character-types+
;; assuming a simple hierarchy
#.
(
coerce
(
loop
*
:for
(
type
next
)
:on
'
(
;; In SCL, all characters seem to be 16-bit base-char
;; Yet somehow character fails to be a subtype of base-char
#-
scl
base-char
;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
#+
lispworks7+
lw:bmp-char
#+
lispworks
lw:simple-char
character
)
:unless
(
and
next
(
subtypep
next
type
))
:collect
type
)
'vector
))
#.
(
coerce
(
loop
:for
(
type
next
)
:on
'
(
;; In SCL, all characters seem to be 16-bit base-char
;; Yet somehow character fails to be a subtype of base-char
#-
scl
base-char
;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
#+
lispworks7+
lw:bmp-char
#+
lispworks
lw:simple-char
character
)
:unless
(
and
next
(
subtypep
next
type
))
:collect
type
)
'vector
))
(
defparameter
+max-character-type-index+
(
1-
(
length
+character-types+
)))
(
defconstant
+non-base-chars-exist-p+
(
plusp
+max-character-type-index+
))
(
when
+non-base-chars-exist-p+
(
pushnew
:non-base-chars-exist-p
*features*
)))
...
...
upgrade.lisp
View file @
0a6a0e77
...
...
@@ -139,10 +139,10 @@ previously-loaded version of ASDF."
(
if
(
consp
x
)
(
values
(
car
x
)
(
cadr
x
))
(
values
x
:asdf
))
(
find-symbol*
s
p
nil
)))
(
asyms
(
l
)
(
mapcar
#'
asym
l
)))
(
loop
*
:for
(
name
superclasses
slots
)
:in
redefined-classes
:for
sym
=
(
find-symbol*
name
:asdf
nil
)
:when
(
and
sym
(
find-class
sym
))
:do
(
eval
`
(
defclass
,
sym
,
(
asyms
superclasses
)
,
(
asyms
slots
)))))))
(
loop
:for
(
name
superclasses
slots
)
:in
redefined-classes
:for
sym
=
(
find-symbol*
name
:asdf
nil
)
:when
(
and
sym
(
find-class
sym
))
:do
(
eval
`
(
defclass
,
sym
,
(
asyms
superclasses
)
,
(
asyms
slots
)))))))
;;; Self-upgrade functions
...
...
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