diff --git a/src/code/float.lisp b/src/code/float.lisp index 3ac65127eb3f78992e0647926c36007d30824033..4616fedf9041625d6390aee441daf0a9392484b8 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -1047,9 +1047,15 @@ (number-dispatch ((x real)) (((foreach single-float double-float #+long-float long-float - #+double-double double-double-float fixnum)) (coerce x ',type)) + #+double-double + ((double-double-float) + ;; Convert the double-double to a double before + ;; coercing to the appropriate type. + (coerce (+ (double-double-hi x) + (double-double-lo x)) + ',type)) ((bignum) (bignum-to-float x ',type)) ((ratio) diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 217bbc919137e7a46e5f95beb4f75a478c4fcedb..12f627f51fbdb32f4183048b660392c12c5f7468 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -1219,6 +1219,32 @@ a host-structure or string." (:version (frob (%pathname-version pathname))))))) +(defun %%pathname-match-p (pathname wildname) + (macrolet ((frob (field &optional (op 'components-match )) + `(or (null (,field wildname)) + (,op (,field pathname) (,field wildname))))) + (and (or (null (%pathname-host wildname)) + (eq (%pathname-host wildname) (%pathname-host pathname))) + (frob %pathname-device) + (frob %pathname-directory directory-components-match) + (frob %pathname-name) + (frob %pathname-type) + (frob %pathname-version)))) + +;; Like PATHNAME-MATCH-P but the pathnames should not be search-lists. +;; Primarily intended for TRANSLATE-LOGICAL-PATHNAME and friends, +;; because PATHNAME-MATCH-P calls TRANSLATE-LOGICAL-PATHNAME, causing +;; infinite recursion. +(defun %pathname-match-p (in-pathname in-wildname) + "Pathname matches the wildname template?" + (declare (type path-designator in-pathname) + ;; Not path-designator because a file-stream can't have a + ;; wild pathname. + (type (or string pathname) in-wildname)) + (with-pathname (pathname in-pathname) + (with-pathname (wildname in-wildname) + (%%pathname-match-p pathname wildname)))) + ;;; PATHNAME-MATCH-P -- Interface ;;; (defun pathname-match-p (in-pathname in-wildname) @@ -1231,17 +1257,8 @@ a host-structure or string." (enumerate-search-list (pathname in-path) (with-pathname (in-wild in-wildname) (enumerate-search-list (wildname in-wild) - (macrolet ((frob (field &optional (op 'components-match )) - `(or (null (,field wildname)) - (,op (,field pathname) (,field wildname))))) - (when (and (or (null (%pathname-host wildname)) - (eq (%pathname-host wildname) (%pathname-host pathname))) - (frob %pathname-device) - (frob %pathname-directory directory-components-match) - (frob %pathname-name) - (frob %pathname-type) - (frob %pathname-version)) - (return-from pathname-match-p pathname)))))))) + (when (%%pathname-match-p pathname wildname) + (return-from pathname-match-p pathname))))))) ;;; SUBSTITUTE-INTO -- Internal @@ -1476,7 +1493,7 @@ a host-structure or string." (with-pathname (source source) (with-pathname (from from-wildname) (with-pathname (to to-wildname) - (unless (pathname-match-p source from) + (unless (%pathname-match-p source from) (didnt-match-error source from)) (let* ((source-host (%pathname-host source)) (to-host (%pathname-host to)) @@ -2171,7 +2188,7 @@ a host-structure or string." :format-control (intl:gettext "No translation for ~S") :format-arguments (list pathname))) (destructuring-bind (from to) x - (when (pathname-match-p pathname from) + (when (%pathname-match-p pathname from) (return (translate-logical-pathname (translate-pathname pathname from to))))))) (pathname pathname) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 9019861bb0e1a5a876f65bd38abd2fe0eb491294..c8a4d93909a8ea32d94b8babb1e1dc7e4434c1a9 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -749,7 +749,13 @@ (read-line object nil nil) (unless line (return)) - (unix:unix-write fd line 0 (length line)) + ;; Take just the low 8 bits of each char + ;; (code) of the string and write that out to + ;; the descriptor. + (let ((output (make-array (length line) :element-type '(unsigned-byte 8)))) + (dotimes (k (length output)) + (setf (aref output k) (ldb (byte 8 0) (char-code (aref line k))))) + (unix:unix-write fd output 0 (length output))) (if no-cr (return) (unix:unix-write fd newline 0 1))))) diff --git a/src/general-info/release-21b.txt b/src/general-info/release-21b.txt index 7489d64110406c3d030f67d325a22e4724309796..44ab2215253dff0d9a83e1512d22f862ed4d8ae7 100644 --- a/src/general-info/release-21b.txt +++ b/src/general-info/release-21b.txt @@ -89,6 +89,11 @@ New in this release: * Ticket #18 fixed: better description of :ENV option for RUN-PROGRAM. * Ticket #22 fixed: Incorrect coercion to float. + * Ticket #25 fixed: Issue with ext:run-program and string streams + (related to character sizes?) + * Ticket #27 fixed: Regression: ASDF test failures + * Ticket #28 fixed: Recursive function definition during + cross-compile * Other changes: diff --git a/tests/issues.lisp b/tests/issues.lisp index 4f7f5ed7d35a6016bc8e0e4f4e2e1b8e8db42f4c..b02fc1266886d13ed1a6771d2f3fe786274ae9ba 100644 --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -210,3 +210,91 @@ (assert-eql 3d0 (funcall tester 3d0)) (assert-eql 4w0 (funcall tester 4w0)))) +(define-test issue.25a + (:tag :issues) + ;; The original test from issue 25, modified slightly for lisp-unit + ;; testing. + (let* ((in-string (format nil "A line.~%And another.~%"))) + (with-output-to-string (out-stream nil) + (with-input-from-string (in-stream in-string) + (ext:run-program "cat" nil + :wait t + :input in-stream + :output out-stream)) + (let ((out-string (get-output-stream-string out-stream))) + (assert-eql (length in-string) (length out-string)) + (assert-equal in-string out-string))))) + +(define-test issue.25b + (:tag :issues) + ;; Modified test to verify that we only write the low 8-bits of each + ;; string character to run-program. + (let* ((in-string (concatenate 'string '(#\greek_small_letter_alpha + #\greek_small_letter_beta))) + (expected (map 'string #'(lambda (c) + (code-char (ldb (byte 8 0) (char-code c)))) + in-string))) + (with-output-to-string (out-stream nil) + (with-input-from-string (in-stream in-string) + (ext:run-program "cat" nil + :wait t + :input in-stream + :output out-stream)) + (let ((out-string (get-output-stream-string out-stream))) + (assert-eql (length out-string) (length out-string)) + ;; For comparison, convert the strings to codes so failures are easier to read + (assert-equal (map 'list #'char-code out-string) + (map 'list #'char-code expected)))))) + +(define-test issue.25c + (:tag :issues) + ;; Modified test to verify that each octet read from run-program is + ;; read into the low 8-bits of each character of the resulting + ;; string. + (let* ((in-string (concatenate 'string '(#\greek_small_letter_alpha + #\greek_small_letter_beta))) + (expected (stream:string-encode in-string :utf16-be)) + (path #p"issue25c.txt")) + (with-open-file (s path :direction :output :if-exists :supersede :external-format :utf16-be) + (write-string in-string s) + (force-output s) + (file-position s 0) + (with-open-file (s1 path :direction :input :element-type '(unsigned-byte 8)) + (with-output-to-string (out-stream) + (ext:run-program "cat" nil + :wait t + :input s1 + :output out-stream) + (let ((out-string (get-output-stream-string out-stream))) + (assert-equal (length out-string) (length expected)) + (assert-equal (map 'list #'char-code out-string) + (map 'list #'char-code expected)))))))) + + +(define-test issue.25d + (:tag :issues) + ;; The original test from issue 25, but using non-ascii characters + ;; and using string-encode/decode to verify that the output and the + ;; input match. + (let* ((in-string (concatenate 'string '(#\greek_small_letter_alpha + #\greek_small_letter_beta + #\greek_small_letter_gamma + #\greek_small_letter_delta + #\greek_small_letter_epsilon + #\greek_small_letter_zeta + #\greek_small_letter_eta + #\greek_small_letter_theta + #\greek_small_letter_iota + #\greek_small_letter_kappa + #\greek_small_letter_lamda)))) + (with-output-to-string (out-stream nil) + (with-input-from-string (in-stream (stream:string-encode in-string :utf8)) + (ext:run-program "cat" nil + :wait t + :input in-stream + :output out-stream)) + (let ((out-string (stream:string-decode (get-output-stream-string out-stream) + :utf8))) + (assert-eql (length in-string) (length out-string)) + (assert-equal in-string out-string))))) + diff --git a/tests/pathname.lisp b/tests/pathname.lisp index 73b31a1e3772a1af727a94dae6d920fbbb727835..6cff018cbf8c3eb4fe74068d5095cb0574eda08f 100644 --- a/tests/pathname.lisp +++ b/tests/pathname.lisp @@ -41,3 +41,35 @@ ;; Tests where both args are search-lists. (assert-true "foo:foo.lisp" "bar:*")) + +;; Verify PATHNAME-MATCH-P works with logical pathnames. (Issue 27) +;; This test modeled after a test from asdf +(defun setup-logical-host () + (let ((root *default-pathname-defaults*) + (bin-type (pathname-type (compile-file-pathname "foo.lisp")))) + (setf (logical-pathname-translations "ASDFTEST") + `((,(format nil "**;*.~a" bin-type) + ,(merge-pathnames (make-pathname :directory '(:relative :wild-inferiors) + :name :wild :type bin-type :version nil))) + (,(format nil "**;*.~a.*" bin-type) + ,(merge-pathnames (make-pathname :directory '(:relative "asdf-bin" :wild-inferiors) + :name :wild :type bin-type + :defaults root))) + ("**;*.*.*" + ,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors) + :name :wild :type :wild :version :wild))) + ("**;*.*" + ,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors) + :name :wild :type :wild :version nil))) + ("**;*" + ,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors) + :name :wild :type nil :version nil))))))) +(setup-logical-host) + +(define-test pathname-match-p.logical-pathname + (assert-true (pathname-match-p + (make-pathname :host "ASDFTEST" + :directory '(:absolute "system2" "module4") + :name nil :type nil) + (parse-namestring "ASDFTEST:system2;module4;")))) +