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
a47b0be1
Commit
a47b0be1
authored
Oct 14, 2013
by
Francois-Rene Rideau
Browse files
Accommodate for lw:simple-char.
parent
b96ddb6a
Changes
4
Hide whitespace changes
Inline
Side-by-side
test/asdf-pathname-test.script
View file @
a47b0be1
...
...
@@ -17,7 +17,8 @@
;;; '/test/{system1,system2}/'
;;; any failure is recorded as a transcript entry which indicates
;;; ( ( 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.
;;; where NIL appears, the probe-file succeeded.
;;;
...
...
@@ -297,7 +298,7 @@
;; :static-file "module2/static-file.type"
collect (make-pathname :directory directory :name "static-file" :type "type"
:defaults root)
;;; source file pathname variations
collect (make-pathname :directory (append directory '("module2")) :name "untyped-file" :type nil
:defaults root)
...
...
@@ -379,7 +380,7 @@
:files files
:modules modules
:systems systems)))))
(when delete-host
(setf (logical-pathname-translations "ASDFTEST") nil))
(clear-system "test-system")))
...
...
test/test-utilities.script
View file @
a47b0be1
...
...
@@ -134,7 +134,7 @@
#+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:register-pre-built-system
asdf/bundle:static-library
uiop/os:parse-file-location-info
uiop/os:parse-windows-shortcut
...
...
@@ -211,14 +211,16 @@
(defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!)
#+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 (unbasify "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 (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-equal +crlf+ (map 'string 'code-char '(13 10)))
...
...
@@ -239,5 +241,5 @@
(ts "c" +crlf+ (strcat ccr +lf+))
(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))
uiop/stream.lisp
View file @
a47b0be1
...
...
@@ -33,7 +33,10 @@
(
in-package
:uiop/stream
)
(
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)"
)
(
defvar
*stdin*
*standard-input*
...
...
uiop/utility.lisp
View file @
a47b0be1
...
...
@@ -19,6 +19,7 @@
#:remove-plist-keys
#:remove-plist-key
;; plists
#:emptyp
;; sequences
#:+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
#:first-char
#:last-char
#:split-string
#:stripln
#:+cr+
#:+lf+
#:+crlf+
#:string-prefix-p
#:string-enclosed-p
#:string-suffix-p
...
...
@@ -187,9 +188,29 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters
(
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*
)))
(
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
(
with-upgradability
()
...
...
@@ -201,10 +222,19 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(
defun
strings-common-element-type
(
strings
)
"What least subtype of CHARACTER can contain all the elements of all the 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
))
#.
(
if
+non-base-chars-exist-p+
`
(
aref
+character-types+
(
loop
:with
index
=
0
:for
s
:in
strings
:do
(
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
)
"Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
...
...
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