;;; 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)
;; 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))))))
\f
#|
(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")
(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)))
;;;
;;; 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)
(: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
(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))
(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
(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))))))
\f
;;; A pathname is logical if the host component is a logical host.
;;; This constructor is used to make an instance of the correct type
(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
: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.
(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
(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/*/")
"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)
--- /dev/null
+;;;; 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)
;;; 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"
projects / sbcl.git / commitdiff