From: William Harold Newman Date: Sun, 20 May 2001 12:53:51 +0000 (+0000) Subject: 0.6.12.10: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3924eb24605ed3ff0951155d271a7fea15656e7d;p=sbcl.git 0.6.12.10: MNA sbcl-devel 2001-05-12 "logical pathname patch & readable hashtables" patch --- diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index a5dbf26..4db23f4 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -648,8 +648,8 @@ (declaim (inline maphash)) (defun maphash (function-designator hash-table) #!+sb-doc - "For each entry in HASH-TABLE, call the designated function on the key - and value of the entry. Return NIL." + "For each entry in HASH-TABLE, call the designated two-argument function + on the key and value of the entry. Return NIL." (let ((fun (%coerce-callable-to-function function-designator)) (size (length (hash-table-next-vector hash-table)))) (declare (type function fun)) @@ -665,33 +665,56 @@ ;;;; methods on HASH-TABLE -(def!method print-object ((ht hash-table) stream) +;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE +;;; when reconstructing HASH-TABLE. +(defun hash-table-ctor-args (hash-table) + (when (hash-table-weak-p hash-table) + ;; FIXME: This might actually work with no trouble, but as of + ;; sbcl-0.6.12.10 when this code was written, weak hash tables + ;; weren't working yet, so I couldn't test it. When weak hash + ;; tables are supported again, this should be fixed. + (error "can't dump weak hash tables readably")) ; defensive programming.. + `(:test ',(hash-table-test hash-table) + :size ',(hash-table-size hash-table) + :rehash-size ',(hash-table-rehash-size hash-table) + :rehash-threshold ',(hash-table-rehash-threshold hash-table))) + +;;; Return an association list representing the same data as HASH-TABLE. +(defun hash-table-alist (hash-table) + (let ((result nil)) + (maphash (lambda (key value) + (push (cons key value) result)) + hash-table) + result)) + +;;; Stuff an association list into HASH-TABLE. Return the hash table, +;;; so that we can use this for the *PRINT-READABLY* case in +;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET +;;; forms and readable gensyms and stuff. +(defun stuff-hash-table (hash-table alist) + (dolist (x alist) + (setf (gethash (car x) hash-table) (cdr x))) + hash-table) + +(def!method print-object ((hash-table hash-table) stream) (declare (type stream stream)) - (print-unreadable-object (ht stream :type t :identity t) - (format stream - ":TEST ~S :COUNT ~D" - (hash-table-test ht) - (hash-table-number-entries ht)))) + (cond ((not *print-readably*) + (print-unreadable-object (hash-table stream :type t :identity t) + (format stream + ":TEST ~S :COUNT ~S" + (hash-table-test hash-table) + (hash-table-count hash-table)))) + ((not *read-eval*) + (error "can't print hash tables readably without *READ-EVAL*")) + (t + (with-standard-io-syntax + (format stream + "#.~W" + `(stuff-hash-table (make-hash-table ,@(hash-table-ctor-args + hash-table)) + ',(hash-table-alist hash-table))))))) (def!method make-load-form ((hash-table hash-table) &optional environment) - (declare (ignorable environment)) - (values - `(make-hash-table - :test ',(hash-table-test hash-table) - :size ',(hash-table-size hash-table) - :rehash-size ',(hash-table-rehash-size hash-table) - :rehash-threshold ',(hash-table-rehash-threshold hash-table)) - (let ((alist nil)) - (maphash (lambda (key value) - (push (cons key value) alist)) - hash-table) - (if alist - ;; FIXME: It'd probably be more efficient here to write the - ;; hash table values as a SIMPLE-VECTOR rather than an alist. - ;; (Someone dumping a huge hash table might well thank us..) - `(stuff-hash-table ,hash-table ',alist) - nil)))) - -(defun stuff-hash-table (table alist) - (dolist (x alist) - (setf (gethash (car x) table) (cdr x)))) + (declare (ignore environment)) + (values `(make-hash-table ,@(hash-table-ctor-args hash-table)) + `(stuff-hash-table ,hash-table ',(hash-table-alist hash-table)))) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index d6b2194..f3dd156 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -71,7 +71,7 @@ ;; but the arguments given in the X3J13 cleanup issue ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the ;; case, and uppercase is the ordinary way to do that. - (flet ((upcase-maybe (x) (typecase x (string (string-upcase x)) (t x)))) + (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x)))) (if (typep host 'logical-host) (%make-logical-pathname host :unspecific @@ -1227,7 +1227,7 @@ a host-structure or string." ;;;; utilities -;;; Canonicalize a logical pathanme word by uppercasing it checking that it +;;; Canonicalize a logical pathname word by uppercasing it checking that it ;;; contains only legal characters. (defun logical-word-or-lose (word) (declare (string word)) diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index 42dbcbd..f2874dc 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -197,5 +197,29 @@ (error "bad PSXHASH behavior for ~S ~S" i j)))) ))) +;;; As of sbcl-0.6.12.10, writing hash tables readably should work. +;;; This isn't required by the ANSI standard, but it should be, since +;;; it's well-defined useful behavior which ANSI prohibits the users +;;; from implementing themselves. (ANSI says the users can't define +;;; their own their own PRINT-OBJECT (HASH-TABLE T) methods, and they +;;; can't even wiggle out of it by subclassing HASH-TABLE or STREAM.) +(let ((original-ht (make-hash-table :test 'equal :size 111)) + (original-keys '(1 10 11 400030002 -100000000))) + (dolist (key original-keys) + (setf (gethash key original-ht) + (expt key 4))) + (let* ((written-ht (with-output-to-string (s) + (write original-ht :stream s :readably t))) + (read-ht (with-input-from-string (s written-ht) + (read s)))) + (assert (= (hash-table-count read-ht) + (hash-table-count original-ht) + (length original-keys))) + (assert (eql (hash-table-test original-ht) (hash-table-test read-ht))) + (assert (eql (hash-table-size original-ht) (hash-table-size read-ht))) + (dolist (key original-keys) + (assert (eql (gethash key read-ht) + (gethash key original-ht)))))) + ;;; success (quit :unix-status 104) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index c85df93..d462c1b 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -73,6 +73,25 @@ (assert (equal pn1 pn2)) (assert (equal pn1 pn3))) +;;; In addition to the upper-case constraint above, if the logical-pathname +;;; contains a string component in e.g. the directory, name and type slot, +;;; these should be valid "WORDS", according to CLHS 19.3.1. +;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be +;;; a TYPE-ERROR? + +;; error: directory-component not valid +(assert (not (ignore-errors + (make-pathname :host "FOO" :directory "!bla" :name "bar")))) + +;; error: name-component not valid +(assert (not (ignore-errors + (make-pathname :host "FOO" :directory "bla" :name "!bar")))) + +;; error: type-component not valid. +(assert (not (ignore-errors + (make-pathname :host "FOO" :directory "bla" :name "bar" + :type "&baz")))) + ;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The ;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC ;;; without actually requiring the system to signal an error (apart @@ -91,6 +110,12 @@ (let ((cond (grab-condition (parse-namestring "foo:jeamland" "demo2")))) (assert (typep cond 'type-error))) +;;; turning one logical pathname into another: +(setf (logical-pathname-translations "foo") + '(("tohome;*.*.*" "home:*.*.*"))) +(assert (equal (namestring (translate-logical-pathname "foo:tohome;x.y")) + "home:x.y")) + ;;; ANSI, in its wisdom, specifies that it's an error (specifically a ;;; TYPE-ERROR) to query the system about the translations of a string ;;; which doesn't have any translations. It's not clear why we don't diff --git a/version.lisp-expr b/version.lisp-expr index 7c34dd9..8e22e01 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.12.9" +"0.6.12.10"