Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
asdf
asdf
Commits
5e8b50cd
Commit
5e8b50cd
authored
Mar 19, 2013
by
Robert P. Goldman
Browse files
Merge branch 'master' of
ssh://common-lisp.net/project/asdf/public_html/asdf
parents
6a7f5896
304923f7
Changes
12
Hide whitespace changes
Inline
Side-by-side
asdf.asd
View file @
5e8b50cd
...
...
@@ -74,7 +74,7 @@
:licence
"MIT"
:description
"Another System Definition Facility"
:long-description
"ASDF builds Common Lisp software organized into defined systems."
:version
"2.32.2
0
"
;; to be automatically updated by make bump-version
:version
"2.32.2
5
"
;; to be automatically updated by make bump-version
:depends-on
()
#+
asdf3
:encoding
#+
asdf3
:utf-8
;; For most purposes, asdf itself specially counts as a builtin system.
...
...
bundle.lisp
View file @
5e8b50cd
...
...
@@ -30,8 +30,12 @@
#+
mkcl
(
do-fasb
:initarg
:do-fasb
:initform
t
:reader
bundle-op-do-fasb-p
)
#+
mkcl
(
do-static-library
:initarg
:do-static-library
:initform
t
:reader
bundle-op-do-static-library-p
)))
(
defclass
bundle-compile-op
(
bundle-op
basic-compile-op
)
()
(
:documentation
"Abstract operation for ways to bundle the outputs of compiling *Lisp* files"
))
;; create a single fasl for the entire library
(
defclass
basic-fasl-op
(
bundle-
op
basic-
compile-op
)
(
defclass
basic-fasl-op
(
bundle-compile-op
)
((
bundle-type
:initform
:fasl
)))
(
defclass
prepare-fasl-op
(
sideway-operation
)
((
sideway-operation
:initform
'load-fasl-op
)))
...
...
@@ -45,19 +49,19 @@
;; we'd have to have the monolithic-op not inherit from the main op,
;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
;; On ECL: compile the system and produce linkable ".a" library for it.
;; On others: just compile the system.
(
defclass
lib-op
(
bundle-op
basic-compile-op
)
((
bundle-type
:initform
#
+
(
or
ecl
mkcl
)
:lib
#-
(
or
ecl
mkcl
)
:no-output-file
)
))
(
defclass
lib-op
(
bundle-compile-op
)
((
bundle-type
:initform
#+
(
or
ecl
mkcl
)
:lib
#-
(
or
ecl
mkcl
)
:no-output-file
))
(
:documentation
#+
(
or
ecl
mkcl
)
"compile the system and produce linkable (.a) library for it."
#
-
(
or
ecl
mkcl
)
"just compile the system"
))
(
defclass
dll-op
(
bundle-op
basic-compile-op
)
;; Link together all the dynamic library used by this system into a single one.
(
(
bundle-type
:initform
:dll
)
))
((
bundle-type
:initform
:dll
))
(
:documentation
"Link together all the dynamic library used by this system into a single one."
))
(
defclass
binary-op
(
bundle-op
basic-compile-op
selfward-operation
)
;; On ECL: produce lib and fasl for the system.
;; On "normal" Lisps: produce just the fasl.
((
selfward-operation
:initform
'
(
lib-op
fasl-op
))
))
((
selfward-operation
:initform
'
(
lib-op
fasl-op
)))
(
:documentation
#+
(
or
ecl
mkcl
)
"produce lib and fasl for the system."
#-
(
or
ecl
mkcl
)
"produce a fasl for the system"
))
(
defclass
monolithic-op
(
operation
)
())
;; operation on a system and its dependencies
...
...
@@ -65,27 +69,34 @@
((
prologue-code
:accessor
monolithic-op-prologue-code
)
(
epilogue-code
:accessor
monolithic-op-epilogue-code
)))
(
defclass
monolithic-binary-op
(
monolithic-bundle-op
basic-compile-op
sideway-operation
selfward-operation
)
;; On ECL: produce lib and fasl for combined system and dependencies.
;; On "normal" Lisps: produce an image file from system and dependencies.
((
selfward-operation
:initform
'
(
monolithic-fasl-op
monolithic-lib-op
))))
(
defclass
monolithic-bundle-compile-op
(
monolithic-bundle-op
bundle-compile-op
)
()
(
:documentation
"Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems"
))
;; Create a single fasl for the system and its dependencies.
(
defclass
monolithic-fasl-op
(
monolithic-bundle-op
basic-fasl-op
)
())
(
defclass
monolithic-binary-op
(
monolithic-bundle-compile-op
sideway-operation
selfward-operation
)
((
selfward-operation
:initform
'
(
monolithic-fasl-op
monolithic-lib-op
)))
(
:documentation
#+
ecl
"produce lib and fasl for combined system and dependencies."
#-
ecl
"produce an image file from system and dependencies (not implemented)."
))
(
defclass
monolithic-fasl-op
(
monolithic-bundle-compile-op
basic-fasl-op
)
()
(
:documentation
"Create a single fasl for the system and its dependencies."
))
(
defclass
monolithic-lib-op
(
monolithic-bundle-op
basic-compile-op
)
;; ECL: Create a single linkable library for the system and its dependencies.
((
bundle-type
:initform
:lib
)))
(
defclass
monolithic-lib-op
(
monolithic-bundle-compile-op
basic-compile-op
)
((
bundle-type
:initform
:lib
))
(
:documentation
#+
(
or
ecl
mkcl
)
"Create a single linkable library for the system and its dependencies."
#-
(
or
ecl
mkcl
)
"Compile a system and its dependencies."
))
(
defclass
monolithic-dll-op
(
monolithic-bundle-op
basic-compile-op
sideway-operation
selfward-operation
)
((
bundle-type
:initform
:dll
)
(
selfward-operation
:initform
'dll-op
)
(
sideway-operation
:initform
'dll-op
)))
(
defclass
program-op
(
monolithic-bundle-
op
selfward-operation
)
;; All: create an executable file from the system and its dependencies
(
defclass
program-op
#+
(
or
mkcl
ecl
)
(
monolithic-bundle-
compile-op
)
#-
(
or
mkcl
ecl
)
(
monolithic-bundle-op
selfward-operation
)
((
bundle-type
:initform
:program
)
(
selfward-operation
:initform
#+
(
or
mkcl
ecl
)
'monolithic-lib-op
#-
(
or
mkcl
ecl
)
'load-op
)))
#-
(
or
mkcl
ecl
)
(
selfward-operation
:initform
#-
(
or
mkcl
ecl
)
'load-op
))
(
:documentation
"create an executable file from the system and its dependencies"
))
(
defun
bundle-pathname-type
(
bundle-type
)
(
etypecase
bundle-type
...
...
@@ -101,13 +112,14 @@
((
eql
:program
)
(
cond
((
os-unix-p
)
nil
)
((
os-windows-p
)
"exe"
)))))
(
defun
bundle-output-files
(
o
c
)
(
let
((
bundle-type
(
bundle-type
o
)))
(
unless
(
eq
bundle-type
:no-output-file
)
;; NIL already means something regarding type.
(
let
((
name
(
or
(
component-build-pathname
c
)
(
format
nil
"~A~@[~A~]"
(
component-name
c
)
(
slot-value
o
'name-suffix
))))
(
type
(
bundle-pathname-type
bundle-type
)))
(
values
(
list
(
subpathname
(
component-pathname
c
)
name
:type
type
))
(
eq
(
type-of
o
)
(
component-build-operation
c
)))))))
(
when
(
input-files
o
c
)
(
let
((
bundle-type
(
bundle-type
o
)))
(
unless
(
eq
bundle-type
:no-output-file
)
;; NIL already means something regarding type.
(
let
((
name
(
or
(
component-build-pathname
c
)
(
format
nil
"~A~@[~A~]"
(
component-name
c
)
(
slot-value
o
'name-suffix
))))
(
type
(
bundle-pathname-type
bundle-type
)))
(
values
(
list
(
subpathname
(
component-pathname
c
)
name
:type
type
))
(
eq
(
type-of
o
)
(
component-build-operation
c
))))))))
(
defmethod
output-files
((
o
bundle-op
)
(
c
system
))
(
bundle-output-files
o
c
))
...
...
@@ -202,36 +214,16 @@
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
(
with-upgradability
()
(
defmethod
component-depends-on
((
o
monolithic-lib-op
)
(
c
system
))
(
declare
(
ignorable
o
))
`
((
lib-op
,@
(
required-components
c
:other-systems
t
:component-type
'system
:goal-operation
(
find-operation
o
'load-op
)
:keep-operation
'compile-op
))
,@
(
call-next-method
)))
(
defmethod
component-depends-on
((
o
monolithic-fasl-op
)
(
c
system
))
(
declare
(
ignorable
o
))
`
((
#-
(
or
ecl
mkcl
)
fasl-op
#+
(
or
ecl
mkcl
)
lib-op
,@
(
required-components
c
:other-systems
t
:component-type
'system
:goal-operation
(
find-operation
o
'load-fasl-op
)
:keep-operation
'fasl-op
))
,@
(
call-next-method
)))
(
defmethod
component-depends-on
((
o
lib-op
)
(
c
system
))
(
declare
(
ignorable
o
))
`
((
compile-op
,@
(
required-components
c
:other-systems
nil
:component-type
'
(
not
system
)
:goal-operation
(
find-operation
o
'load-op
)
:keep-operation
'compile-op
))
,@
(
call-next-method
)))
#-
ecl
(
defmethod
component-depends-on
((
o
fasl-op
)
(
c
system
))
`
(
,@
(
component-depends-on
(
find-operation
o
'lib-op
)
c
)
,@
(
call-next-method
)))
(
defmethod
component-depends-on
((
o
dll-op
)
c
)
`
(
,@
(
component-depends-on
(
find-operation
o
'lib-op
)
c
)
(
defmethod
component-depends-on
((
o
bundle-compile-op
)
(
c
system
))
`
(
,
(
if
(
operation-monolithic-p
o
)
`
(
#-
(
or
ecl
mkcl
)
fasl-op
#+
(
or
ecl
mkcl
)
lib-op
,@
(
required-components
c
:other-systems
t
:component-type
'system
:goal-operation
(
find-operation
o
'load-op
)
:keep-operation
'compile-op
))
`
(
compile-op
,@
(
required-components
c
:other-systems
nil
:component-type
'
(
not
system
)
:goal-operation
(
find-operation
o
'load-op
)
:keep-operation
'compile-op
)))
,@
(
call-next-method
)))
(
defmethod
component-depends-on
:around
((
o
bundle-op
)
(
c
component
))
...
...
@@ -249,7 +241,7 @@
(
loop
:for
f
:in
(
funcall
key
sub-o
sub-c
)
:when
(
funcall
test
f
)
:do
(
collect
f
))))))
(
defmethod
input-files
((
o
bundle-op
)
(
c
system
))
(
defmethod
input-files
((
o
bundle-
compile-
op
)
(
c
system
))
(
direct-dependency-files
o
c
:test
'bundlable-file-p
:key
'output-files
))
(
defun
select-bundle-operation
(
type
&optional
monolithic
)
...
...
@@ -311,7 +303,8 @@
nil
)
(
defmethod
perform
((
o
load-fasl-op
)
(
c
system
))
(
perform-lisp-load-fasl
o
c
))
(
when
(
input-files
o
c
)
(
perform-lisp-load-fasl
o
c
)))
(
defmethod
mark-operation-done
:after
((
o
load-fasl-op
)
(
c
system
))
(
mark-operation-done
(
find-operation
o
'load-op
)
c
)))
...
...
@@ -395,13 +388,13 @@
s
)))))
#-
(
or
ecl
mkcl
)
(
defmethod
perform
((
o
b
asic-fasl
-op
)
(
c
system
))
(
defmethod
perform
((
o
b
undle-compile
-op
)
(
c
system
))
(
let*
((
input-files
(
input-files
o
c
))
(
fasl-files
(
remove
(
compile-file-type
)
input-files
:key
#'
pathname-type
:test-not
#'
equalp
))
(
non-fasl-files
(
remove
(
compile-file-type
)
input-files
:key
#'
pathname-type
:test
#'
equalp
))
(
output-files
(
output-files
o
c
))
(
output-file
(
first
output-files
)))
(
unless
input-files
(
format
t
"WTF no input-files for ~S on ~S !???"
o
c
))
;;
(unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
(
when
input-files
(
assert
output-files
)
(
when
non-fasl-files
...
...
@@ -432,22 +425,23 @@
#+
ecl
(
with-upgradability
()
(
defmethod
perform
((
o
bundle-op
)
(
c
system
))
(
defmethod
perform
((
o
bundle-
compile-
op
)
(
c
system
))
(
let*
((
object-files
(
input-files
o
c
))
(
output
(
output-files
o
c
))
(
bundle
(
first
output
))
(
kind
(
bundle-type
o
)))
(
create-image
bundle
(
append
object-files
(
bundle-op-lisp-files
o
))
:kind
kind
:entry-point
(
component-entry-point
c
)
:prologue-code
(
when
(
typep
o
'monolithic-bundle-op
)
(
monolithic-op-prologue-code
o
))
:epilogue-code
(
when
(
typep
o
'monolithic-bundle-op
)
(
monolithic-op-epilogue-code
o
))
:build-args
(
bundle-op-build-args
o
)))))
(
when
output
(
create-image
bundle
(
append
object-files
(
bundle-op-lisp-files
o
))
:kind
kind
:entry-point
(
component-entry-point
c
)
:prologue-code
(
when
(
typep
o
'monolithic-bundle-op
)
(
monolithic-op-prologue-code
o
))
:epilogue-code
(
when
(
typep
o
'monolithic-bundle-op
)
(
monolithic-op-epilogue-code
o
))
:build-args
(
bundle-op-build-args
o
))))))
#+
mkcl
(
with-upgradability
()
...
...
header.lisp
View file @
5e8b50cd
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.32.2
0
: Another System Definition Facility.
;;; This is ASDF 2.32.2
5
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
test/make-hello-world.lisp
View file @
5e8b50cd
...
...
@@ -2,11 +2,17 @@
#+
lispworks
(
lispworks:load-all-patches
)
(
load
(
make-pathname
:name
"script-support"
:defaults
*load-pathname*
))
(
load-asdf
)
(
asdf-test::frob-packages
)
#+
ecl
(
require
:cmp
)
#+
ecl
(
trace
uiop:compile-file*
uiop:load*
)
(
asdf-test::register-directory
asdf-test::*asdf-directory*
)
;; we need asdf-driver, and ECL can dump.
(
asdf-test::register-directory
asdf-test::*uiop-directory*
)
(
asdf:upgrade-asdf
)
;; may recompile and rename away package asdf?
(
asdf-test::frob-packages
)
(
with-test
()
(
register-directory
*asdf-directory*
)
;; we need asdf-driver, and ECL can dump.
(
register-directory
*uiop-directory*
)
;;(dolist (s '(:asdf :asdf/driver :asdf/defsystem :uiop)) (DBG :foo s (asdf::builtin-system-p (find-system s))))
(
trace
perform-plan
perform
)
(
operate
'load-fasl-op
:hello-world-example
)
(
operate
'program-op
:hello-world-example
))
test/run-tests.sh
View file @
5e8b50cd
...
...
@@ -25,13 +25,13 @@ usage () {
unset
DEBUG_ASDF_TEST upgrade clean_load load_systems test_interactively extract_all
SHELL
=
/bin/sh
export
SHELL
export
SHELL
DEBUG_ASDF_TEST GCL_ANSI ASDF_OUTPUT_TRANSLATIONS
while
getopts
"cdtHulhu"
OPTION
do
case
$OPTION
in
d
)
export
DEBUG_ASDF_TEST
=
t
DEBUG_ASDF_TEST
=
t
;;
u
)
upgrade
=
t
...
...
@@ -183,12 +183,12 @@ case "$lisp" in
flags
=
"-norc -eval (ext::install-bytecodes-compiler)"
eval
=
"-eval"
;;
gcl
)
export
GCL_ANSI
=
t
GCL_ANSI
=
t
command
=
"
${
GCL
:-
gcl
}
"
flags
=
"-batch"
eval
=
"-eval"
;;
gclcvs
)
export
GCL_ANSI
=
t
GCL_ANSI
=
t
command
=
"
${
GCLCVS
:-
gclcvs
}
"
flags
=
"-batch"
eval
=
"-eval"
;;
...
...
@@ -332,7 +332,6 @@ run_upgrade_tests () {
mkdir
-p
build/results/
rm
-f
build/
*
.
*
f
*
uiop/
*
.
*
f
*
test
/
*
.
*
f
*
## Remove stale FASLs from ASDF 1.x, especially when different implementations have same name
ASDF_OUTPUT_TRANSLATIONS
=
"(:output-translations (
\"
${
ASDFDIR
}
\"
(
\"
${
ASDFDIR
}
/build/fasls/
\"
:implementation
\"
asdf/
\"
)) (t (
\"
${
ASDFDIR
}
/build/fasls/
\"
:implementation
\"
root/
\"
)) :ignore-inherited-configuration)"
export
ASDF_OUTPUT_TRANSLATIONS
su
=
test
/script-support.lisp
for
tag
in
`
upgrade_tags
`
;
do
for
method
in
`
upgrade_methods
`
;
do
...
...
test/test-asdf.asd
View file @
5e8b50cd
...
...
@@ -64,3 +64,9 @@
(
defsystem
:test-asdf/test-source-directory-2
:pathname
"some/relative/pathname/with-file.type"
)
(
defsystem
:test-asdf/bundle-1
:components
((
:file
"file1"
)
(
:file
"file3"
)))
(
defsystem
:test-asdf/bundle-2
:depends-on
(
:test-asdf/bundle-1
)
:components
((
:file
"file2"
)))
test/test-bundle.script
View file @
5e8b50cd
...
...
@@ -8,26 +8,22 @@
;;;---------------------------------------------------------------------------
(asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(asdf:clear-system :test-bundle-1)
(asdf:clear-system :test-bundle-2)
(asdf:clear-system :test-
asdf/
bundle-1)
(asdf:clear-system :test-
asdf/
bundle-2)
(when (find-package :test-package) (delete-package :test-package))
(def-test-system :test-bundle-1
:components ((:file "file1") (:file "file3")))
(def-test-system :test-bundle-2
:depends-on (:test-bundle-1) :components ((:file "file2")))
#+(or abcl (and ecl ecl-bytecmp) gcl)
(leave-test "bundles not on this implementation" 0)
(defparameter *bundle-1* (output-file 'fasl-op :test-bundle-1))
(defparameter *bundle-2* (output-file 'fasl-op :test-bundle-2))
(defparameter *mono-bundle-2* (output-file 'monolithic-fasl-op :test-bundle-2))
(defparameter *bundle-1* (output-file 'fasl-op :test-
asdf/
bundle-1))
(defparameter *bundle-2* (output-file 'fasl-op :test-
asdf/
bundle-2))
(defparameter *mono-bundle-2* (output-file 'monolithic-fasl-op :test-
asdf/
bundle-2))
(DBG :test-bundle *bundle-1* *bundle-2*)
(assert-equal (list *bundle-2*)
(input-files 'load-fasl-op :test-bundle-2))
(input-files 'load-fasl-op :test-
asdf/
bundle-2))
(delete-file-if-exists *bundle-1*)
(delete-file-if-exists *bundle-2*)
(delete-file-if-exists *mono-bundle-2*)
(operate 'load-fasl-op :test-bundle-2)
(operate 'load-fasl-op :test-
asdf/
bundle-2)
(DBG "Check that the bundles were indeed created.")
(assert (probe-file *bundle-2*))
(assert (probe-file *bundle-1*))
...
...
@@ -35,5 +31,5 @@
(assert (symbol-value (find-symbol* :*file1* :test-package)))
(assert (symbol-value (find-symbol* :*file3* :test-package)))
(DBG "Now for the mono-fasl")
(operate 'monolithic-fasl-op :test-bundle-2)
(operate 'monolithic-fasl-op :test-
asdf/
bundle-2)
(assert (probe-file *mono-bundle-2*))
test/test-utilities.script
View file @
5e8b50cd
...
...
@@ -135,14 +135,15 @@
asdf/lisp-action:try-recompiling
;; types
asdf/bundle:user-system
#+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
;; on some implementations only
asdf/bundle:bundle-system
asdf/bundle:register-pre-built-system
asdf/bundle:static-library
asdf
/os:parse-file-location-info
asdf
/os:parse-windows-shortcut
asdf
/os:read-little-endian
asdf
/os:read-null-terminated-string
uiop
/os:parse-file-location-info
uiop
/os:parse-windows-shortcut
uiop
/os:read-little-endian
uiop
/os:read-null-terminated-string
;; backward compatibility upgrade only
asdf/backward-internals:make-sub-operation
asdf/find-system:contrib-sysdef-search
...
...
@@ -196,3 +197,27 @@
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))))
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/1.x"))))
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))))
#+(and sbcl sb-unicode) (assert +non-base-chars-exist-p+)
#+(or clozure (and sbcl (not sb-unicode))) (assert (not +non-base-chars-exist-p+))
(assert (base-string-p (make-string 10 :element-type 'base-char)))
(assert-equal "abcd" (strcat "a" NIL "bc" "d"))
(assert-equal "abcd" (reduce/strcat '("a" NIL "bc" "d")))
#-non-base-chars-exist-p
(progn
(assert (base-string-p (make-string 10 :element-type 'character))))
(defun basify (s) (coerce s 'base-string))
#+non-base-chars-exist-p
(progn
(assert (not (base-string-p (make-string 10 :element-type 'character))))
(assert (not (base-string-p "abc")))
(assert (base-string-p (basify "abc")))
(assert (not (base-string-p (strcat "a" NIL #\b "cd"))))
(assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" NIL "cd")))))
(assert (base-string-p (strcat (basify "ab") (basify "cd"))))
(assert (not (base-string-p (strcat (basify "ab") #\c "d"))))
(assert (base-string-p (strcat (basify "ab") #\c #\d))))
uiop/lisp-build.lisp
View file @
5e8b50cd
...
...
@@ -15,6 +15,8 @@
#:compile-warned-warning
#:compile-failed-warning
#:check-lisp-compile-results
#:check-lisp-compile-warnings
#:*uninteresting-conditions*
#:*uninteresting-compiler-conditions*
#:*uninteresting-loader-conditions*
;; Types
#+
sbcl
#:sb-grovel-unknown-constant-condition
;; Functions & Macros
#:get-optimization-settings
#:proclaim-optimization-settings
#:call-with-muffled-compiler-conditions
#:with-muffled-compiler-conditions
...
...
uiop/utility.lisp
View file @
5e8b50cd
...
...
@@ -18,7 +18,9 @@
#:while-collecting
#:appendf
#:length=n-p
#:ensure-list
;; lists
#:remove-plist-keys
#:remove-plist-key
;; plists
#:emptyp
;; sequences
#:strcat
#:first-char
#:last-char
#:split-string
;; strings
#:+non-base-chars-exist-p+
;; characters
#:base-string-p
#:strings-common-element-type
#:reduce/strcat
#:strcat
;; strings
#:first-char
#:last-char
#:split-string
#:string-prefix-p
#:string-enclosed-p
#:string-suffix-p
#:find-class*
;; CLOS
#:stamp<
#:stamps<
#:stamp*<
#:stamp<=
;; stamps
...
...
@@ -183,10 +185,42 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(
or
(
null
x
)
(
and
(
vectorp
x
)
(
zerop
(
length
x
))))))
;;; Characters
(
with-upgradability
()
(
defconstant
+non-base-chars-exist-p+
(
not
(
subtypep
'character
'base-char
)))
(
when
+non-base-chars-exist-p+
(
pushnew
:non-base-chars-exist-p
*features*
)))
;;; Strings
(
with-upgradability
()
(
defun
base-string-p
(
string
)
(
declare
(
ignorable
string
))
(
and
#+
non-base-chars-exist-p
(
eq
'base-char
(
array-element-type
string
))))
(
defun
strings-common-element-type
(
strings
)
(
declare
(
ignorable
strings
))
#-
non-base-chars-exist-p
'character
#+
non-base-chars-exist-p
(
if
(
loop
:for
s
:in
strings
:always
(
or
(
null
s
)
(
typep
s
'base-char
)
(
base-string-p
s
)))
'base-char
'character
))
(
defun
reduce/strcat
(
strings
&key
key
start
end
)
"Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
NIL is interpreted as an empty string. A character is interpreted as a string of length one."
(
when
(
or
start
end
)
(
setf
strings
(
subseq
strings
start
end
)))
(
when
key
(
setf
strings
(
mapcar
key
strings
)))
(
loop
:with
output
=
(
make-string
(
loop
:for
s
:in
strings
:sum
(
if
(
characterp
s
)
1
(
length
s
)))
:element-type
(
strings-common-element-type
strings
))
:with
pos
=
0
:for
input
:in
strings
:do
(
etypecase
input
(
null
)
(
character
(
setf
(
char
output
pos
)
input
)
(
incf
pos
))
(
string
(
replace
output
input
:start1
pos
)
(
incf
pos
(
length
input
))))
:finally
(
return
output
)))
(
defun
strcat
(
&rest
strings
)
(
apply
'concatenate
'string
strings
))
(
reduce/strcat
strings
))
(
defun
first-char
(
s
)
(
and
(
stringp
s
)
(
plusp
(
length
s
))
(
char
s
0
)))
...
...
upgrade.lisp
View file @
5e8b50cd
...
...
@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(
asdf-version
"2.32.2
0
"
)
(
asdf-version
"2.32.2
5
"
)
(
existing-version
(
asdf-version
)))
(
setf
*asdf-version*
asdf-version
)
(
when
(
and
existing-version
(
not
(
equal
asdf-version
existing-version
)))
...
...
version.lisp-expr
View file @
5e8b50cd
"2.32.2
0
"
"2.32.2
5
"
Write
Preview
Supports
Markdown
0%
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!
Cancel
Please
register
or
sign in
to comment