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
Jan Moringen
asdf
Commits
a47b0be1
Commit
a47b0be1
authored
11 years ago
by
Francois-Rene Rideau
Browse files
Options
Downloads
Patches
Plain Diff
Accommodate for lw:simple-char.
parent
b96ddb6a
No related branches found
No related tags found
No related merge requests found
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
test/asdf-pathname-test.script
+4
-3
4 additions, 3 deletions
test/asdf-pathname-test.script
test/test-utilities.script
+7
-5
7 additions, 5 deletions
test/test-utilities.script
uiop/stream.lisp
+4
-1
4 additions, 1 deletion
uiop/stream.lisp
uiop/utility.lisp
+35
-5
35 additions, 5 deletions
uiop/utility.lisp
with
50 additions
and
14 deletions
test/asdf-pathname-test.script
+
4
−
3
View file @
a47b0be1
...
@@ -17,7 +17,8 @@
...
@@ -17,7 +17,8 @@
;;; '/test/{system1,system2}/'
;;; '/test/{system1,system2}/'
;;; any failure is recorded as a transcript entry which indicates
;;; any failure is recorded as a transcript entry which indicates
;;; ( ( system-pathname module-pathname file-pathname ) missing-pathnames )
;;; ( ( system-pathname module-pathname file-pathname ) missing-pathnames )
;;; where missing pathnames is a list of the component-pathname values which failed to designate an intended file.
;;; where missing pathnames is a list of the component-pathname values
;;; which failed to designate an intended file.
;;; If there, if the pathname is logical, both the logical and physical pathname appears.
;;; If there, if the pathname is logical, both the logical and physical pathname appears.
;;; where NIL appears, the probe-file succeeded.
;;; where NIL appears, the probe-file succeeded.
;;;
;;;
...
@@ -297,7 +298,7 @@
...
@@ -297,7 +298,7 @@
;; :static-file "module2/static-file.type"
;; :static-file "module2/static-file.type"
collect (make-pathname :directory directory :name "static-file" :type "type"
collect (make-pathname :directory directory :name "static-file" :type "type"
:defaults root)
:defaults root)
;;; source file pathname variations
;;; source file pathname variations
collect (make-pathname :directory (append directory '("module2")) :name "untyped-file" :type nil
collect (make-pathname :directory (append directory '("module2")) :name "untyped-file" :type nil
:defaults root)
:defaults root)
...
@@ -379,7 +380,7 @@
...
@@ -379,7 +380,7 @@
:files files
:files files
:modules modules
:modules modules
:systems systems)))))
:systems systems)))))
(when delete-host
(when delete-host
(setf (logical-pathname-translations "ASDFTEST") nil))
(setf (logical-pathname-translations "ASDFTEST") nil))
(clear-system "test-system")))
(clear-system "test-system")))
...
...
This diff is collapsed.
Click to expand it.
test/test-utilities.script
+
7
−
5
View file @
a47b0be1
...
@@ -134,7 +134,7 @@
...
@@ -134,7 +134,7 @@
#+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
#+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
;; on some implementations only
;; on some implementations only
asdf/bundle:bundle-system
asdf/bundle:bundle-system
asdf/bundle:register-pre-built-system
asdf/bundle:register-pre-built-system
asdf/bundle:static-library
asdf/bundle:static-library
uiop/os:parse-file-location-info
uiop/os:parse-file-location-info
uiop/os:parse-windows-shortcut
uiop/os:parse-windows-shortcut
...
@@ -211,14 +211,16 @@
...
@@ -211,14 +211,16 @@
(defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!)
(defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!)
#+non-base-chars-exist-p
#+non-base-chars-exist-p
(progn
(let* ((limit-char (code-char (1- char-code-limit)))
(limit-string (string limit-char)))
(assert (not (base-string-p limit-string)))
(assert (not (base-string-p (make-string 10 :element-type 'character))))
(assert (not (base-string-p (make-string 10 :element-type 'character))))
(assert (not (base-string-p (unbasify "abc"))))
(assert (not (base-string-p (unbasify "abc"))))
(assert (base-string-p (basify "abc")))
(assert (base-string-p (basify "abc")))
(assert
(not
(base-string-p (strcat "a" nil #\b (unbasify "cd"))))
)
(assert (base-string-p (strcat "a" nil #\b (unbasify "cd"))))
(assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" nil "cd")))))
(assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" nil "cd")))))
(assert (base-string-p (strcat (basify "ab") (basify "cd"))))
(assert (base-string-p (strcat (basify "ab") (basify "cd"))))
(assert (not (base-string-p (strcat (basify "ab") #\c (unbasify "d")))))
(assert (not (base-string-p (strcat (basify "ab") #\c
limit-char
(unbasify "d")))))
(assert (base-string-p (strcat (basify "ab") #\c #\d))))
(assert (base-string-p (strcat (basify "ab") #\c #\d))))
(assert-equal +crlf+ (map 'string 'code-char '(13 10)))
(assert-equal +crlf+ (map 'string 'code-char '(13 10)))
...
@@ -239,5 +241,5 @@
...
@@ -239,5 +241,5 @@
(ts "c" +crlf+ (strcat ccr +lf+))
(ts "c" +crlf+ (strcat ccr +lf+))
(ts (strcat acrlf "b") +lf+ (strcat acrlf blf)))
(ts (strcat acrlf "b") +lf+ (strcat acrlf blf)))
(with-temporary-file (:stream s :direction :io
:element-type 'character
:prefix "LEP")
(with-temporary-file (:stream s :direction :io :prefix "LEP")
(println "Hello, World" s))
(println "Hello, World" s))
This diff is collapsed.
Click to expand it.
uiop/stream.lisp
+
4
−
1
View file @
a47b0be1
...
@@ -33,7 +33,10 @@
...
@@ -33,7 +33,10 @@
(
in-package
:uiop/stream
)
(
in-package
:uiop/stream
)
(
with-upgradability
()
(
with-upgradability
()
(
defvar
*default-stream-element-type*
(
or
#+
(
or
abcl
cmu
cormanlisp
scl
xcl
)
'character
:default
)
(
defvar
*default-stream-element-type*
(
or
#+
(
or
abcl
cmu
cormanlisp
scl
xcl
)
'character
#+
lispworks
'lw:simple-char
:default
)
"default element-type for open (depends on the current CL implementation)"
)
"default element-type for open (depends on the current CL implementation)"
)
(
defvar
*stdin*
*standard-input*
(
defvar
*stdin*
*standard-input*
...
...
This diff is collapsed.
Click to expand it.
uiop/utility.lisp
+
35
−
5
View file @
a47b0be1
...
@@ -19,6 +19,7 @@
...
@@ -19,6 +19,7 @@
#:remove-plist-keys
#:remove-plist-key
;; plists
#:remove-plist-keys
#:remove-plist-key
;; plists
#:emptyp
;; sequences
#:emptyp
;; sequences
#:+non-base-chars-exist-p+
;; characters
#:+non-base-chars-exist-p+
;; characters
#:+max-character-type-index+
#:character-type-index
#:+character-types+
#:base-string-p
#:strings-common-element-type
#:reduce/strcat
#:strcat
;; strings
#:base-string-p
#:strings-common-element-type
#:reduce/strcat
#:strcat
;; strings
#:first-char
#:last-char
#:split-string
#:stripln
#:+cr+
#:+lf+
#:+crlf+
#:first-char
#:last-char
#:split-string
#:stripln
#:+cr+
#:+lf+
#:+crlf+
#:string-prefix-p
#:string-enclosed-p
#:string-suffix-p
#:string-prefix-p
#:string-enclosed-p
#:string-suffix-p
...
@@ -187,9 +188,29 @@ Returns two values: \(A B C\) and \(1 2 3\)."
...
@@ -187,9 +188,29 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters
;;; Characters
(
with-upgradability
()
(
with-upgradability
()
(
defconstant
+non-base-chars-exist-p+
(
not
(
subtypep
'character
'base-char
)))
(
defconstant
+non-base-chars-exist-p+
(
not
(
subtypep
'character
'base-char
)))
;; ECL, LW, SBCL
(
when
+non-base-chars-exist-p+
(
pushnew
:non-base-chars-exist-p
*features*
)))
(
when
+non-base-chars-exist-p+
(
pushnew
:non-base-chars-exist-p
*features*
)))
(
with-upgradability
()
(
defparameter
+character-types+
;; assuming a simple hierarchy
#(#+
non-base-chars-exist-p
base-char
#+
lispworks
lw:simple-char
character
))
(
defparameter
+max-character-type-index+
(
1-
(
length
+character-types+
))))
(
with-upgradability
()
(
defun
character-type-index
(
x
)
(
declare
(
ignorable
x
))
#.
(
case
+max-character-type-index+
(
0
0
)
(
1
'
(
etypecase
x
(
character
(
if
(
typep
x
'base-char
)
0
1
))
(
symbol
(
if
(
subtypep
x
'base-char
)
0
1
))))
(
otherwise
'
(
or
(
position-if
(
etypecase
x
(
character
#'
(
lambda
(
type
)
(
typep
x
type
)))
(
symbol
#'
(
lambda
(
type
)
(
subtypep
x
type
))))
+character-types+
)
(
error
"Not a character or character type: ~S"
x
))))))
;;; Strings
;;; Strings
(
with-upgradability
()
(
with-upgradability
()
...
@@ -201,10 +222,19 @@ Returns two values: \(A B C\) and \(1 2 3\)."
...
@@ -201,10 +222,19 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(
defun
strings-common-element-type
(
strings
)
(
defun
strings-common-element-type
(
strings
)
"What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
"What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
(
declare
(
ignorable
strings
))
(
declare
(
ignorable
strings
))
#-
non-base-chars-exist-p
'character
#.
(
if
+non-base-chars-exist-p+
#+
non-base-chars-exist-p
`
(
aref
+character-types+
(
if
(
loop
:for
s
:in
strings
:always
(
or
(
null
s
)
(
typep
s
'base-char
)
(
base-string-p
s
)))
(
loop
:with
index
=
0
:for
s
:in
strings
:do
'base-char
'character
))
(
cond
((
=
index
,
+max-character-type-index+
)
(
return
index
))
((
emptyp
s
))
;; NIL or empty string
((
characterp
s
)
(
setf
index
(
max
index
(
character-type-index
s
))))
((
stringp
s
)
(
unless
(
>=
index
(
character-type-index
(
array-element-type
s
)))
(
setf
index
(
reduce
'max
s
:key
#'
character-type-index
:initial-value
index
))))
(
t
(
error
"Invalid string designator ~S for ~S"
s
'strings-common-element-type
)))
:finally
(
return
index
)))
'
'character
))
(
defun
reduce/strcat
(
strings
&key
key
start
end
)
(
defun
reduce/strcat
(
strings
&key
key
start
end
)
"Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
"Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
...
...
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