From: William Harold Newman Date: Wed, 4 Apr 2001 19:47:19 +0000 (+0000) Subject: 0.6.11.31: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1c347eae5ec81b6f41db9d27c1fe6d34abe1d3ca;p=sbcl.git 0.6.11.31: Pierre Mai READ-SEQUENCE/CONCATENATED-STREAM fix (cmucl-imp 2001-03-26) removed broken ".~D" file versioning added PRINT-OBJECT for LOGICAL-HOST so that LOGICAL-PATHNAMEs would print more nicely added ~_ in PRINT-OBJECT (LOGICAL-PATHNAME T) removed unused &OPTIONAL INDENT from DEFPRINTER-FOO functions removed redundant/ugly indentation in DEFPRINTER expansion --- diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 0d40d30..3154ef4 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -442,12 +442,12 @@ ;;; These functions are called by the expansion of the DEFPRINTER ;;; macro to do the actual printing. -(declaim (ftype (function (symbol t stream &optional t) (values)) +(declaim (ftype (function (symbol t stream) (values)) defprinter-prin1 defprinter-princ)) -(defun defprinter-prin1 (name value stream &optional indent) +(defun defprinter-prin1 (name value stream) (declare (ignore indent)) (defprinter-prinx #'prin1 name value stream)) -(defun defprinter-princ (name value stream &optional indent) +(defun defprinter-princ (name value stream) (declare (ignore indent)) (defprinter-prinx #'princ name value stream)) (defun defprinter-prinx (prinx name value stream) @@ -529,8 +529,6 @@ ;; FIXME: should probably be byte-compiled (pprint-logical-block (,stream nil) (print-unreadable-object (structure ,stream :type t) - (when *print-pretty* - (pprint-indent :block 2 ,stream)) ,@(nreverse reversed-prints)))))) #| diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 753da60..6cd4c40 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -385,22 +385,17 @@ (collect ((strings)) (let* ((name (%pathname-name pathname)) (type (%pathname-type pathname)) - (type-supplied (not (or (null type) (eq type :unspecific)))) - (version (%pathname-version pathname)) - (version-supplied (not (or (null version) (eq version :newest))))) + (type-supplied (not (or (null type) (eq type :unspecific))))) + ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when + ;; translating logical pathnames to a filesystem without + ;; versions (like Unix). (when name (strings (unparse-unix-piece name))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) (strings ".") - (strings (unparse-unix-piece type))) - (when version-supplied - (unless type-supplied - (error "cannot specify the version without a type: ~S" pathname)) - (strings (if (eq version :wild) - ".*" - (format nil ".~D" version))))) + (strings (unparse-unix-piece type)))) (apply #'concatenate 'simple-string (strings)))) (/show0 "filesys.lisp 406") diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 7b44fae..2498723 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -26,20 +26,24 @@ (customary-case (required-argument) :type (member :upper :lower))) (def!struct (logical-host - (:include host - (:parse #'parse-logical-namestring) - (:unparse #'unparse-logical-namestring) - (:unparse-host - (lambda (x) - (logical-host-name (%pathname-host x)))) - (:unparse-directory #'unparse-logical-directory) - (:unparse-file #'unparse-unix-file) - (:unparse-enough #'unparse-enough-namestring) - (:customary-case :upper))) + (:include host + (:parse #'parse-logical-namestring) + (:unparse #'unparse-logical-namestring) + (:unparse-host + (lambda (x) + (logical-host-name (%pathname-host x)))) + (:unparse-directory #'unparse-logical-directory) + (:unparse-file #'unparse-unix-file) + (:unparse-enough #'unparse-enough-namestring) + (:customary-case :upper))) (name "" :type simple-base-string) (translations nil :type list) (canon-transls nil :type list)) +(def!method print-object ((logical-host logical-host) stream) + (print-unreadable-object (logical-host stream :type t) + (prin1 (logical-host-name logical-host) stream))) + ;;; A PATTERN is a list of entries and wildcards used for pattern ;;; matches of translations. (sb!xc:defstruct (pattern (:constructor make-pattern (pieces))) @@ -90,7 +94,7 @@ ;;; ;;; Physical pathnames include all these slots and a device slot. -;;; Logical pathnames are a subclass of pathname. Their class +;;; Logical pathnames are a subclass of PATHNAME. Their class ;;; relations are mimicked using structures for efficency. (sb!xc:defstruct (logical-pathname (:conc-name %logical-pathname-) (:include pathname) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 4e66f41..b09bacf 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -891,16 +891,17 @@ (:include lisp-stream (in #'concatenated-in) (bin #'concatenated-bin) + (n-bin #'concatenated-n-bin) (misc #'concatenated-misc)) (:constructor #!-high-security-support make-concatenated-stream #!+high-security-support %make-concatenated-stream (&rest streams &aux (current streams))) (:copier nil)) - ;; The car of this is the stream we are reading from now. + ;; The car of this is the substream we are reading from now. current - ;; This is a list of all the streams. We need to remember them so that - ;; we can close them. + ;; This is a list of all the substreams there ever were. We need to + ;; remember them so that we can close them. ;; ;; FIXME: ANSI says this is supposed to be the list of streams that ;; we still have to read from. So either this needs to become a @@ -936,7 +937,8 @@ (macrolet ((in-fun (name fun) `(defun ,name (stream eof-error-p eof-value) - (do ((current (concatenated-stream-current stream) (cdr current))) + (do ((current (concatenated-stream-current stream) + (cdr current))) ((null current) (eof-or-lose stream eof-error-p eof-value)) (let* ((stream (car current)) @@ -946,6 +948,22 @@ (in-fun concatenated-in read-char) (in-fun concatenated-bin read-byte)) +(defun concatenated-n-bin (stream buffer start numbytes eof-errorp) + (do ((current (concatenated-stream-current stream) (cdr current)) + (current-start start) + (remaining-bytes numbytes)) + ((null current) + (if eof-errorp + (error 'end-of-file :stream stream) + (- numbytes remaining-bytes))) + (let* ((stream (car current)) + (bytes-read (read-n-bytes stream buffer current-start + remaining-bytes nil))) + (incf current-start bytes-read) + (decf remaining-bytes bytes-read) + (when (zerop remaining-bytes) (return numbytes))) + (setf (concatenated-stream-current stream) (cdr current)))) + (defun concatenated-misc (stream operation &optional arg1 arg2) (let ((left (concatenated-stream-current stream))) (when left diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 37cff3e..eea013f 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -51,15 +51,16 @@ (let ((namestring (handler-case (namestring pathname) (error nil)))) (if namestring - (format stream "#.(logical-pathname ~S)" namestring) + (format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring) (print-unreadable-object (pathname stream :type t) - (format stream - ":HOST ~S :DIRECTORY ~S :FILE ~S :NAME=~S :VERSION ~S" - (%pathname-host pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname)))))) + (format + stream + "~_:HOST ~S ~_:DIRECTORY ~S ~_:FILE ~S ~_:NAME ~S ~_:VERSION ~S" + (%pathname-host pathname) + (%pathname-directory pathname) + (%pathname-name pathname) + (%pathname-type pathname) + (%pathname-version pathname)))))) ;;; A pathname is logical if the host component is a logical host. ;;; This constructor is used to make an instance of the correct type @@ -457,7 +458,8 @@ a host-structure or string." (type (or string pathname-component-tokens) device) (type (or list string pattern pathname-component-tokens) directory) (type (or string pattern pathname-component-tokens) name type) - (type (or integer pathname-component-tokens (member :newest)) version) + (type (or integer pathname-component-tokens (member :newest)) + version) (type (or pathname-designator null) defaults) (type (member :common :local) case)) (let* ((defaults (when defaults @@ -1426,7 +1428,8 @@ a host-structure or string." :offset (cdadr chunks))))) (parse-host (logical-chunkify namestr start end))) (values host :unspecific - (and (not (equal (directory)'(:absolute)))(directory)) + (and (not (equal (directory)'(:absolute))) + (directory)) name type version)))) ;;; We can't initialize this yet because not all host methods are loaded yet. @@ -1558,7 +1561,7 @@ a host-structure or string." (defun translate-logical-pathname (pathname &key) #!+sb-doc - "Translates pathname to a physical pathname, which is returned." + "Translate PATHNAME to a physical pathname, which is returned." (declare (type pathname-designator pathname) (values (or null pathname))) (typecase pathname diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 0824498..c85df93 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -98,13 +98,18 @@ (let ((cond (grab-condition (logical-pathname-translations "unregistered-host")))) (assert (typep cond 'type-error))) -;;; examples from CLHS: Section 19.4, Logical Pathname Translations -;;; (sometimes converted to the Un*x way of things) +;;; FIXME: A comment on this section up to sbcl-0.6.11.30 or so said +;;; examples from CLHS: Section 19.4, LOGICAL-PATHNAME-TRANSLATIONS +;;; (sometimes converted to the Un*x way of things) +;;; but when I looked it up I didn't see the connection. Presumably +;;; there's some code in this section which should be attributed +;;; to something in the ANSI spec, but I don't know what code it is +;;; or what section of the specification has the related code. (setf (logical-pathname-translations "test0") '(("**;*.*.*" "/library/foo/**/"))) (assert (equal (namestring (translate-logical-pathname - "test0:foo;bar;baz;mum.quux.3")) - "/library/foo/foo/bar/baz/mum.quux.3")) + "test0:foo;bar;baz;mum.quux")) + "/library/foo/foo/bar/baz/mum.quux")) (setf (logical-pathname-translations "prog") '(("RELEASED;*.*.*" "MY-UNIX:/sys/bin/my-prog/") ("RELEASED;*;*.*.*" "MY-UNIX:/sys/bin/my-prog/*/") @@ -122,5 +127,12 @@ "prog:code;documentation.lisp")) "/lib/prog/docum.lisp")) +;;; ANSI section 19.3.1.1.5 specifies that translation to a filesystem +;;; which doesn't have versions should ignore the version slot. CMU CL +;;; didn't ignore this as it should, but we do. +(assert (equal (namestring (translate-logical-pathname + "test0:foo;bar;baz;mum.quux.3")) + "/library/foo/foo/bar/baz/mum.quux")) + ;;; success (quit :unix-status 104) diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp new file mode 100644 index 0000000..b0af043 --- /dev/null +++ b/tests/stream.pure.lisp @@ -0,0 +1,56 @@ +;;;; tests related to Lisp streams + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +;;; Until sbcl-0.6.11.31, we didn't have an N-BIN method for +;;; CONCATENATED-STRING, so stuff like this would fail. +(let ((stream (make-concatenated-stream (make-string-input-stream "Demo"))) + (buffer (make-string 4))) + (read-sequence buffer stream)) +;;; test for the new N-BIN method doing what it's supposed to +(let* ((substrings (list "This " "is " "a " "" + "test of concatenated streams behaving " + "as ordinary streams do under READ-SEQUENCE. " + (make-string 140041 :initial-element #\%) + "For any size of read.." + (make-string 4123 :initial-element #\.) + "they should give the same results." + (make-string (expt 2 14) :initial-element #\*) + "There should be no differences.")) + (substreams (mapcar #'make-string-input-stream substrings)) + (concatenated-stream (apply #'make-concatenated-stream substreams)) + (concatenated-string (apply #'concatenate 'string substrings)) + (stream (make-string-input-stream concatenated-string)) + (max-n-to-read 24) + (buffer-1 (make-string max-n-to-read)) + (buffer-2 (make-string max-n-to-read))) + (loop + (let* ((n-to-read (random max-n-to-read)) + (n-actually-read-1 (read-sequence buffer-1 + concatenated-stream + :end n-to-read)) + (n-actually-read-2 (read-sequence buffer-2 + stream + :end n-to-read))) +;; (format t "buffer-1=~S~%buffer-2=~S~%" buffer-1 buffer-2) + (assert (= n-actually-read-1 n-actually-read-2)) + (assert (string= buffer-1 buffer-2 + :end1 n-actually-read-1 + :end2 n-actually-read-2)) + (unless (= n-actually-read-1 n-to-read) + (assert (< n-actually-read-1 n-to-read)) + (return))))) + +;;; success +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 6c84bf6..2bce8a5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.30" +"0.6.11.31"