From 0f3d47226b4c3f9fcc350e681443534701d56aa4 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 10 May 2002 10:48:34 +0000 Subject: [PATCH] 0.7.3.13: Fix bug 22, throwing an error for bad directives inside ~< ~:> format blocks. Bugfix for host-namestring (and associated host-using functions): ... make the physical host name be "" (not "Unix), as this cannot be a logical host name ... some sanity checking in logical host functionality regarding this change Remove fixed buglets from BUGS Added .cvsignore files for files built in warm init. --- BUGS | 22 +--------------------- NEWS | 2 ++ src/assembly/alpha/.cvsignore | 4 ++++ src/assembly/ppc/.cvsignore | 4 ++++ src/assembly/sparc/.cvsignore | 4 ++++ src/assembly/x86/.cvsignore | 4 ++++ src/code/.cvsignore | 7 +++++++ src/code/filesys.lisp | 6 +++++- src/code/late-format.lisp | 28 ++++++++++++++++++++++++++-- src/code/target-format.lisp | 13 ++++++++++--- src/code/target-pathname.lisp | 13 +++++++++++++ src/pcl/.cvsignore | 37 +++++++++++++++++++++++++++++++++++++ tests/pathnames.impure.lisp | 36 ++++++++++++++++++++++++++++++------ tests/print.impure.lisp | 6 ++++++ version.lisp-expr | 2 +- 15 files changed, 154 insertions(+), 34 deletions(-) create mode 100644 src/assembly/alpha/.cvsignore create mode 100644 src/assembly/ppc/.cvsignore create mode 100644 src/assembly/sparc/.cvsignore create mode 100644 src/assembly/x86/.cvsignore create mode 100644 src/code/.cvsignore create mode 100644 src/pcl/.cvsignore diff --git a/BUGS b/BUGS index 96b7140..8399c2b 100644 --- a/BUGS +++ b/BUGS @@ -142,15 +142,6 @@ WORKAROUND: DTC's recommended workaround from the mailing list 3 Mar 2000: (setf (pcl::find-class 'ccc1) (pcl::find-class 'ccc)) -22: - The ANSI spec, in section "22.3.5.2 Tilde Less-Than-Sign: Logical Block", - says that an error is signalled if ~W, ~_, ~<...~:>, ~I, or ~:T is used - inside "~<..~>" (without the colon modifier on the closing syntax). - However, SBCL doesn't do this: - * (FORMAT T "~" 12) - munge12egnum - NIL - 27: Sometimes (SB-EXT:QUIT) fails with Argh! maximum interrupt nesting depth (4096) exceeded, exiting @@ -269,8 +260,6 @@ WORKAROUND: MERGE also have the same problem. c: (COERCE 'AND 'FUNCTION) returns something related to (MACRO-FUNCTION 'AND), but ANSI says it should raise an error. - f: (FLOAT-RADIX 2/3) should signal an error instead of - returning 2. g: (LOAD "*.lsp") should signal FILE-ERROR. h: (MAKE-CONCATENATED-STREAM (MAKE-STRING-OUTPUT-STREAM)) should signal TYPE-ERROR. @@ -279,10 +268,6 @@ WORKAROUND: TYPE-ERROR when handed e.g. the results of MAKE-STRING-INPUT-STREAM or MAKE-STRING-OUTPUT-STREAM in the inappropriate positions, but doesn't. - j: (PARSE-NAMESTRING (COERCE (LIST #\f #\o #\o (CODE-CHAR 0) #\4 #\8) - (QUOTE STRING))) - should probably signal an error instead of making a pathname with - a null byte in it. k: READ-BYTE is supposed to signal TYPE-ERROR when its argument is not a binary input stream, but instead cheerfully reads from character streams, e.g. (MAKE-STRING-INPUT-STREAM "abc"). @@ -667,7 +652,7 @@ WORKAROUND: but SBCL doesn't do this. (Also as reported by AL in the same message, SBCL depended on this nonconforming behavior to build itself, because of the way that **CURRENT-SEGMENT** was implemented. - As of sbcl-0.6.12.x, this dependence on the nonconforming behavior + As of sbcl-0.7.3.x, this dependence on the nonconforming behavior has been fixed, but the nonconforming behavior remains.) 104: @@ -1220,11 +1205,6 @@ WORKAROUND: isn't too surprising since there are many differences in stack implementation and GC conservatism between the X86 and other ports.) -163: - HOST-NAMESTRING on a Unix pathname returns "Unix", which isn't - treated as a valid host by anything else in the system. (Reported by - Erik Naggum on comp.lang.lisp 2002-04-18) - 164: The type system still can't quite deal with all useful identities; for instance, as of sbcl-0.7.2.18, the type specifier '(and (real -1 diff --git a/NEWS b/NEWS index d190480..08d6990 100644 --- a/NEWS +++ b/NEWS @@ -1111,6 +1111,8 @@ changes in sbcl-0.7.4 relative to sbcl-0.7.3: * The fasl file format has changed again, because dynamic loading on OpenBSD (which has non-ELF object files) motivated some cleanups in the way that foreign symbols are transformed and passed around. + * HOST-NAMESTRING on physical pathnames now returns a string that is + valid as a host argument to MERGE-PATHNAMES and to MAKE-PATHNAME. planned incompatible changes in 0.7.x: * When the profiling interface settles down, maybe in 0.7.x, maybe diff --git a/src/assembly/alpha/.cvsignore b/src/assembly/alpha/.cvsignore new file mode 100644 index 0000000..26ab28f --- /dev/null +++ b/src/assembly/alpha/.cvsignore @@ -0,0 +1,4 @@ +alloc.fasl +arith.fasl +array.fasl +assem-rtns.fasl diff --git a/src/assembly/ppc/.cvsignore b/src/assembly/ppc/.cvsignore new file mode 100644 index 0000000..26ab28f --- /dev/null +++ b/src/assembly/ppc/.cvsignore @@ -0,0 +1,4 @@ +alloc.fasl +arith.fasl +array.fasl +assem-rtns.fasl diff --git a/src/assembly/sparc/.cvsignore b/src/assembly/sparc/.cvsignore new file mode 100644 index 0000000..26ab28f --- /dev/null +++ b/src/assembly/sparc/.cvsignore @@ -0,0 +1,4 @@ +alloc.fasl +arith.fasl +array.fasl +assem-rtns.fasl diff --git a/src/assembly/x86/.cvsignore b/src/assembly/x86/.cvsignore new file mode 100644 index 0000000..26ab28f --- /dev/null +++ b/src/assembly/x86/.cvsignore @@ -0,0 +1,4 @@ +alloc.fasl +arith.fasl +array.fasl +assem-rtns.fasl diff --git a/src/code/.cvsignore b/src/code/.cvsignore new file mode 100644 index 0000000..f8ef852 --- /dev/null +++ b/src/code/.cvsignore @@ -0,0 +1,7 @@ +describe.fasl +force-delayed-defbangmethods.fasl +foreign.fasl +inspect.fasl +ntrace.fasl +profile.fasl +run-program.fasl diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 05809d3..b4d48c6 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -272,7 +272,11 @@ (defun unparse-unix-host (pathname) (declare (type pathname pathname) (ignore pathname)) - "Unix") + ;; this host designator needs to be recognized as a physical host in + ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but + ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR, + ;; 2002-05-09 + "") (defun unparse-unix-piece (thing) (etypecase thing diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 9063fa4..a7d63bd 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -948,6 +948,23 @@ ;;;; format directives and support functions for justification +(defparameter *illegal-inside-justification* + (mapcar (lambda (x) (parse-directive x 0)) + '("~W" "~:W" "~@W" "~:@W" + "~_" "~:_" "~@_" "~:@_" + "~:>" "~:@>" + "~I" "~:I" "~@I" "~:@I" + "~:T" "~:@T"))) + +(defun illegal-inside-justification-p (directive) + (member directive *illegal-inside-justification* + :test (lambda (x y) + (and (format-directive-p x) + (format-directive-p y) + (eql (format-directive-character x) (format-directive-character y)) + (eql (format-directive-colonp x) (format-directive-colonp y)) + (eql (format-directive-atsignp x) (format-directive-atsignp y)))))) + (def-complex-format-directive #\< (colonp atsignp params string end directives) (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) @@ -958,8 +975,15 @@ close params string end) (expand-format-logical-block prefix per-line-p insides suffix atsignp)) - (expand-format-justification segments colonp atsignp - first-semi params)) + (let ((count (apply #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :args (list count))) + (expand-format-justification segments colonp atsignp + first-semi params))) remaining))) (def-complex-format-directive #\> () diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index b5e23c5..8d87aa4 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -1067,9 +1067,16 @@ (interpret-format-logical-block stream orig-args args prefix per-line-p insides suffix atsignp)) - (interpret-format-justification stream orig-args args - segments colonp atsignp - first-semi params))) + (let ((count (apply #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :args (list count))) + (interpret-format-justification stream orig-args args + segments colonp atsignp + first-semi params)))) remaining)) (defun interpret-format-justification diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index f259f2f..760399a 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -499,6 +499,7 @@ a host-structure or string." ;; It seems an error message is appropriate. (host (typecase host (host host) ; A valid host, use it. + ((string 0) *unix-host*) ; "" cannot be a logical host (string (find-logical-host host t)) ; logical-host or lose. (t default-host))) ; unix-host (diddle-args (and (eq (host-customary-case host) :lower) @@ -758,6 +759,12 @@ a host-structure or string." ;; A logical host is an object of implementation-dependent nature. In ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT). (let ((found-host (etypecase host + ((string 0) + ;; This is a special host. It's not valid as a + ;; logical host, so it is a sensible thing to + ;; designate the physical Unix host object. So + ;; we do that. + *unix-host*) (string ;; In general ANSI-compliant Common Lisps, a ;; string might also be a physical pathname host, @@ -1140,6 +1147,12 @@ a host-structure or string." ;;; contains only legal characters. (defun logical-word-or-lose (word) (declare (string word)) + (when (string= word "") + (error 'namestring-parse-error + :complaint "Attempted to treat invalid logical hostname ~ + as a logical host:~% ~S" + :args (list word) + :namestring word :offset 0)) (let ((word (string-upcase word))) (dotimes (i (length word)) (let ((ch (schar word i))) diff --git a/src/pcl/.cvsignore b/src/pcl/.cvsignore new file mode 100644 index 0000000..e513b6a --- /dev/null +++ b/src/pcl/.cvsignore @@ -0,0 +1,37 @@ +boot.fasl +braid.fasl +cache.fasl +combin.fasl +compiler-support.fasl +cpl.fasl +ctypes.fasl +defclass.fasl +defcombin.fasl +defs.fasl +describe.fasl +dfun.fasl +dlisp2.fasl +dlisp3.fasl +dlisp.fasl +documentation.fasl +early-low.fasl +env.fasl +fast-init.fasl +fixup.fasl +fngen.fasl +fsc.fasl +generic-functions.fasl +gray-streams-class.fasl +gray-streams.fasl +init.fasl +low.fasl +macros.fasl +methods.fasl +precom1.fasl +precom2.fasl +print-object.fasl +slots-boot.fasl +slots.fasl +std-class.fasl +vector.fasl +walk.fasl diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index c7ee31b..00da4c0 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -177,8 +177,13 @@ ;;;; or failure in these tests doesn't tell you anything about ;;;; ANSI-compliance unless your PARSE-NAMESTRING works like ours. -(setf (logical-pathname-translations "scratch") - '(("**;*.*.*" "/usr/local/doc/**/*"))) +;;; Needs to be done at compile time, so that the #p"" read-macro +;;; correctly parses things as logical pathnames. This is not a +;;; problem as was, as this is an impure file and so gets loaded in, +;;; but just for future proofing... +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (logical-pathname-translations "scratch") + '(("**;*.*.*" "/usr/local/doc/**/*")))) (loop for (expected-result . params) in `(;; trivial merge @@ -194,7 +199,7 @@ ;; as a name) (#p"/dir/name.supplied-type" ,(make-pathname :type "supplied-type") - #p"/dir/name.type") + #p"/dir/name.type") ;; If (pathname-directory pathname) is a list whose car is ;; :relative, and (pathname-directory default-pathname) is a ;; list, then the merged directory is [...] @@ -205,18 +210,26 @@ (#P"/aaa/bbb/ccc/blah/eee" ;; "../" in a namestring is parsed as :up not :back, so make-pathname ,(make-pathname :directory '(:relative :back "blah")) - #p"/aaa/bbb/ccc/ddd/eee") + #p"/aaa/bbb/ccc/ddd/eee") ;; If (pathname-directory default-pathname) is not a list or ;; (pathname-directory pathname) is not a list whose car is ;; :relative, the merged directory is (or (pathname-directory ;; pathname) (pathname-directory default-pathname)) (#P"/absolute/path/name.type" #p"/absolute/path/name" - #p"/dir/default-name.type") + #p"/dir/default-name.type") ;; === logical pathnames === ;; recognizes a logical pathname namestring when ;; default-pathname is a logical pathname - ;; FIXME: 0.6.12.23 fails this one. + ;; FIXME: 0.6.12.23 fails this one. + ;; + ;; And, as it happens, it's right to fail it. Because + ;; #p"name1" is read in with the ambient *d-p-d* value, which + ;; has a physical (Unix) host; therefore, the host of the + ;; default-pathname argument to merge-pathnames is + ;; irrelevant. The result is (correctly) different if + ;; '#p"name1"' is replaced by "name1", below, though it's + ;; still not what one might expect... -- CSR, 2002-05-09 #+nil (#P"scratch:foo;name1" #p"name1" #p"scratch:foo;") ;; or when the namestring begins with the name of a defined ;; logical host followed by a colon [I assume that refers to pathname @@ -251,5 +264,16 @@ do (assert (string= (namestring (apply #'merge-pathnames params)) (namestring expected-result)))) +;;; host-namestring testing +(assert (string= + (namestring (parse-namestring "/foo" (host-namestring #p"/bar"))) + "/foo")) +(assert (string= + (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR"))) + "SCRATCH:FOO")) +(assert (raises-error? + (setf (logical-pathname-translations "") + (list '("**;*.*.*" "/**/*.*"))))) + ;;;; success (quit :unix-status 104) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index d9fa69e..c12fe05 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -85,5 +85,11 @@ (assert (string= (format nil "~/cl-user:print-foo:print-foo/" 2) "2")) (assert (string= (format nil "~/cl-user::print-foo:print-foo/" 2) "2")) +;;; Check for error detection of illegal directives in a~<..~> justify +;;; block (see ANSI section 22.3.5.2) +(assert (raises-error? (format nil "~<~W~>" 'foo))) +(assert (raises-error? (format nil "~<~<~A~:>~>" '(foo)))) +(assert (string= (format nil "~<~<~A~>~>" 'foo) "FOO")) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index d619eef..cf8daf5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.3.12" +"0.7.3.13" -- 1.7.10.4