r11859: Canonicalize whitespace
authorKevin M. Rosenberg <kevin@rosenberg.net>
Fri, 31 Aug 2007 18:04:31 +0000 (18:04 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Fri, 31 Aug 2007 18:04:31 +0000 (18:04 +0000)
src.lisp
tests.lisp

index f231793..6ba0417 100644 (file)
--- a/src.lisp
+++ b/src.lisp
@@ -8,7 +8,7 @@
 ;;
 ;; This code is free software; you can redistribute it and/or
 ;; modify it under the terms of the version 2.1 of
-;; the GNU Lesser General Public License as published by 
+;; the GNU Lesser General Public License as published by
 ;; the Free Software Foundation, as clarified by the
 ;; preamble found here:
 ;;     http://opensource.franz.com/preamble.html
   (:use #:cl)
   #-allegro (:nicknames #:net.uri)
   (:export
-   #:uri                               ; the type and a function
+   #:uri                                ; the type and a function
    #:uri-p
    #:copy-uri
 
-   #:uri-scheme                                ; and slots
+   #:uri-scheme                         ; and slots
    #:uri-host #:uri-port
    #:uri-path
    #:uri-query
    #:uri-fragment
    #:uri-plist
-   #:uri-authority                     ; pseudo-slot accessor
+   #:uri-authority                      ; pseudo-slot accessor
+
+   #:urn                                ; class
+   #:urn-nid                            ; pseudo-slot accessor
+   #:urn-nss                            ; pseudo-slot accessor
 
-   #:urn                               ; class
-   #:urn-nid                           ; pseudo-slot accessor
-   #:urn-nss                           ; pseudo-slot accessor
-   
    #:*strict-parse*
    #:parse-uri
    #:merge-uris
@@ -51,7 +51,7 @@
    #:uri-parsed-path
    #:render-uri
 
-   #:make-uri-space                    ; interning...
+   #:make-uri-space                     ; interning...
    #:uri-space
    #:uri=
    #:intern-uri
       (setq docstring (car forms))
       (setq forms (cdr forms)))
     (when (and (listp (car forms))
-              (symbolp (caar forms))
-              (string-equal (symbol-name '#:declare)
-                            (symbol-name (caar forms))))
+               (symbolp (caar forms))
+               (string-equal (symbol-name '#:declare)
+                             (symbol-name (caar forms))))
       (setq declarations (car forms))
       (setq forms (cdr forms)))
     (values docstring declarations forms)))
 
-  
+
 (defun shrink-vector (str size)
   #+allegro
   (excl::.primcall 'sys::shrink-svector str size)
   ((fmt-control :initarg :fmt-control :accessor fmt-control)
    (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments ))
   (:report (lambda (c stream)
-            (format stream "Parse error:")
-            (apply #'format stream (fmt-control c) (fmt-arguments c)))))
+             (format stream "Parse error:")
+             (apply #'format stream (fmt-control c) (fmt-arguments c)))))
 
 (defun .parse-error (fmt &rest args)
   (error 'uri-parse-error :fmt-control fmt :fmt-arguments args))
 
 #-allegro (defvar *current-case-mode* :case-insensitive-upper)
 #+allegro (eval-when (:compile-toplevel :load-toplevel :execute)
-           (import '(excl:*current-case-mode*
-                     excl:delimited-string-to-list
-                     excl::parse-body
-                     excl::internal-reader-error
-                     excl:if*)))
+            (import '(excl:*current-case-mode*
+                      excl:delimited-string-to-list
+                      excl::parse-body
+                      excl::internal-reader-error
+                      excl:if*)))
 
 #-allegro
 (defmethod position-char (char (string string) start max)
   (declare (optimize (speed 3) (safety 0) (space 0))
-          (fixnum start max) (string string))
+           (fixnum start max) (string string))
   (do* ((i start (1+ i)))
        ((= i max) nil)
     (declare (fixnum i))
     (when (char= char (char string i)) (return i))))
 
-#-allegro 
-(defun delimited-string-to-list (string &optional (separator #\space) 
+#-allegro
+(defun delimited-string-to-list (string &optional (separator #\space)
                                         skip-terminal)
   (declare (optimize (speed 3) (safety 0) (space 0)
-                    (compilation-speed 0))
-          (type string string)
-          (type character separator))
+                     (compilation-speed 0))
+           (type string string)
+           (type character separator))
   (do* ((len (length string))
-       (output '())
-       (pos 0)
-       (end (position-char separator string pos len)
-            (position-char separator string pos len)))
+        (output '())
+        (pos 0)
+        (end (position-char separator string pos len)
+             (position-char separator string pos len)))
        ((null end)
-       (if (< pos len)
-           (push (subseq string pos) output)
+        (if (< pos len)
+            (push (subseq string pos) output)
           (when (and (plusp len) (not skip-terminal))
             (push "" output)))
         (nreverse output))
     (declare (type fixnum pos len)
-            (type (or null fixnum) end))
+             (type (or null fixnum) end))
     (push (subseq string pos end) output)
     (setq pos (1+ end))))
 
 
   (defmacro if* (&rest args)
     (do ((xx (reverse args) (cdr xx))
-        (state :init)
-        (elseseen nil)
-        (totalcol nil)
-       (lookat nil nil)
-        (col nil))
-       ((null xx)
-        (cond ((eq state :compl)
-               `(cond ,@totalcol))
-              (t (error "if*: illegal form ~s" args))))
+         (state :init)
+         (elseseen nil)
+         (totalcol nil)
+        (lookat nil nil)
+         (col nil))
+        ((null xx)
+         (cond ((eq state :compl)
+                `(cond ,@totalcol))
+               (t (error "if*: illegal form ~s" args))))
       (cond ((and (symbolp (car xx))
-                 (member (symbol-name (car xx))
-                         if*-keyword-list
-                         :test #'string-equal))
-            (setq lookat (symbol-name (car xx)))))
+                  (member (symbol-name (car xx))
+                          if*-keyword-list
+                          :test #'string-equal))
+             (setq lookat (symbol-name (car xx)))))
 
        (cond ((eq state :init)
-             (cond (lookat (cond ((string-equal lookat "thenret")
-                                  (setq col nil
-                                        state :then))
-                                 (t (error
-                                     "if*: bad keyword ~a" lookat))))
-                   (t (setq state :col
-                            col nil)
-                      (push (car xx) col))))
-            ((eq state :col)
-             (cond (lookat
-                    (cond ((string-equal lookat "else")
-                           (cond (elseseen
-                                  (error
-                                   "if*: multiples elses")))
-                           (setq elseseen t)
-                           (setq state :init)
-                           (push `(t ,@col) totalcol))
-                          ((string-equal lookat "then")
-                           (setq state :then))
-                          (t (error "if*: bad keyword ~s"
-                                             lookat))))
-                   (t (push (car xx) col))))
-            ((eq state :then)
-             (cond (lookat
-                    (error
-                     "if*: keyword ~s at the wrong place " (car xx)))
-                   (t (setq state :compl)
-                      (push `(,(car xx) ,@col) totalcol))))
-            ((eq state :compl)
-             (cond ((not (string-equal lookat "elseif"))
-                    (error "if*: missing elseif clause ")))
-             (setq state :init))))))
+              (cond (lookat (cond ((string-equal lookat "thenret")
+                                   (setq col nil
+                                         state :then))
+                                  (t (error
+                                      "if*: bad keyword ~a" lookat))))
+                    (t (setq state :col
+                             col nil)
+                       (push (car xx) col))))
+             ((eq state :col)
+              (cond (lookat
+                     (cond ((string-equal lookat "else")
+                            (cond (elseseen
+                                   (error
+                                    "if*: multiples elses")))
+                            (setq elseseen t)
+                            (setq state :init)
+                            (push `(t ,@col) totalcol))
+                           ((string-equal lookat "then")
+                            (setq state :then))
+                           (t (error "if*: bad keyword ~s"
+                                              lookat))))
+                    (t (push (car xx) col))))
+             ((eq state :then)
+              (cond (lookat
+                     (error
+                      "if*: keyword ~s at the wrong place " (car xx)))
+                    (t (setq state :compl)
+                       (push `(,(car xx) ,@col) totalcol))))
+             ((eq state :compl)
+              (cond ((not (string-equal lookat "elseif"))
+                     (error "if*: missing elseif clause ")))
+              (setq state :init))))))
 
 
 (defclass uri ()
     `(defmethod (setf ,name) :around (new-value (self uri))
        (declare (ignore new-value))
        (prog1 (call-next-method)
-        (setf (uri-string self) nil)
-        ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil)))
-        (setf (uri-hashcode self) nil))))
+         (setf (uri-string self) nil)
+         ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil)))
+         (setf (uri-hashcode self) nil))))
   )
 
 (clear-caching-on-slot-change uri-scheme)
 (defmethod uri-p ((thing t)) nil)
 
 (defun copy-uri (uri
-                &key place
-                     (scheme (when uri (uri-scheme uri)))
-                     (host (when uri (uri-host uri)))
-                     (port (when uri (uri-port uri)))
-                     (path (when uri (uri-path uri)))
-                     (parsed-path
-                      (when uri (copy-list (.uri-parsed-path uri))))
-                     (query (when uri (uri-query uri)))
-                     (fragment (when uri (uri-fragment uri)))
-                     (plist (when uri (copy-list (uri-plist uri))))
-                     (class (when uri (class-of uri)))
-                &aux (escaped (when uri (uri-escaped uri))))
+                 &key place
+                      (scheme (when uri (uri-scheme uri)))
+                      (host (when uri (uri-host uri)))
+                      (port (when uri (uri-port uri)))
+                      (path (when uri (uri-path uri)))
+                      (parsed-path
+                       (when uri (copy-list (.uri-parsed-path uri))))
+                      (query (when uri (uri-query uri)))
+                      (fragment (when uri (uri-fragment uri)))
+                      (plist (when uri (copy-list (uri-plist uri))))
+                      (class (when uri (class-of uri)))
+                 &aux (escaped (when uri (uri-escaped uri))))
   (if* place
      then (setf (uri-scheme place) scheme)
-         (setf (uri-host place) host)
-         (setf (uri-port place) port)
-         (setf (uri-path place) path)
-         (setf (.uri-parsed-path place) parsed-path)
-         (setf (uri-query place) query)
-         (setf (uri-fragment place) fragment)
-         (setf (uri-plist place) plist)
-         (setf (uri-escaped place) escaped)
-         (setf (uri-string place) nil)
-         (setf (uri-hashcode place) nil)
-         place
+          (setf (uri-host place) host)
+          (setf (uri-port place) port)
+          (setf (uri-path place) path)
+          (setf (.uri-parsed-path place) parsed-path)
+          (setf (uri-query place) query)
+          (setf (uri-fragment place) fragment)
+          (setf (uri-plist place) plist)
+          (setf (uri-escaped place) escaped)
+          (setf (uri-string place) nil)
+          (setf (uri-hashcode place) nil)
+          place
    elseif (eq 'uri class)
      then ;; allow the compiler to optimize the call to make-instance:
-         (make-instance 'uri
-           :scheme scheme :host host :port port :path path
-           :parsed-path parsed-path
-           :query query :fragment fragment :plist plist
-           :escaped escaped :string nil :hashcode nil)
+          (make-instance 'uri
+            :scheme scheme :host host :port port :path path
+            :parsed-path parsed-path
+            :query query :fragment fragment :plist plist
+            :escaped escaped :string nil :hashcode nil)
      else (make-instance class
-           :scheme scheme :host host :port port :path path
-           :parsed-path parsed-path
-           :query query :fragment fragment :plist plist
-           :escaped escaped :string nil :hashcode nil)))
+            :scheme scheme :host host :port port :path path
+            :parsed-path parsed-path
+            :query query :fragment fragment :plist plist
+            :escaped escaped :string nil :hashcode nil)))
 
 (defmethod uri-parsed-path ((uri uri))
   (when (uri-path uri)
     (when (null (.uri-parsed-path uri))
       (setf (.uri-parsed-path uri)
-       (parse-path (uri-path uri) (uri-escaped uri))))
+        (parse-path (uri-path uri) (uri-escaped uri))))
     (.uri-parsed-path uri)))
 
 (defmethod (setf uri-parsed-path) (path-list (uri uri))
   (assert (and (consp path-list)
-              (or (member (car path-list) '(:absolute :relative)
-                          :test #'eq))))
+               (or (member (car path-list) '(:absolute :relative)
+                           :test #'eq))))
   (setf (uri-path uri) (render-parsed-path path-list t))
   (setf (.uri-parsed-path uri) path-list)
   path-list)
 
 (defun reserved-char-vector (chars &key except)
   (do* ((a (make-array 127 :element-type 'bit :initial-element 0))
-       (chars chars (cdr chars))
-       (c (car chars) (car chars)))
+        (chars chars (cdr chars))
+        (c (car chars) (car chars)))
       ((null chars) a)
     (if* (and except (member c except :test #'char=))
        thenret
 (defparameter *reserved-characters*
     (reserved-char-vector
      (append *excluded-characters*
-            '(#\; #\/ #\? #\: #\@ #\& #\= #\+ #\$ #\, #\%))))
+             '(#\; #\/ #\? #\: #\@ #\& #\= #\+ #\$ #\, #\%))))
 (defparameter *reserved-authority-characters*
     (reserved-char-vector
      (append *excluded-characters* '(#\; #\/ #\? #\: #\@))))
 (defparameter *reserved-path-characters*
     (reserved-char-vector
      (append *excluded-characters*
-            '(#\;
+             '(#\;
 ;;;;The rfc says this should be here, but it doesn't make sense.
-              ;; #\=
-              #\/ #\?))))
+               ;; #\=
+               #\/ #\?))))
 
 (defparameter *reserved-fragment-characters*
     (reserved-char-vector (remove #\# *excluded-characters*)))
 (eval-when (:compile-toplevel :execute)
 (defun gen-char-range-list (start end)
   (do* ((res '())
-       (endcode (1+ (char-int end)))
-       (chcode (char-int start)
-               (1+ chcode))
-       (hyphen nil))
+        (endcode (1+ (char-int end)))
+        (chcode (char-int start)
+                (1+ chcode))
+        (hyphen nil))
       ((= chcode endcode)
        ;; - has to be first, otherwise it signifies a range!
        (if* hyphen
-         then (setq res (nreverse res))
-              (push #\- res)
-              res
-         else (nreverse res)))
+          then (setq res (nreverse res))
+               (push #\- res)
+               res
+          else (nreverse res)))
     (if* (= #.(char-int #\-) chcode)
        then (setq hyphen t)
        else (push (code-char chcode) res))))
 (defparameter *valid-nid-characters*
     (reserved-char-vector
      '#.(nconc (gen-char-range-list #\a #\z)
-              (gen-char-range-list #\A #\Z)
-              (gen-char-range-list #\0 #\9)
-              '(#\- #\. #\+))))
+               (gen-char-range-list #\A #\Z)
+               (gen-char-range-list #\0 #\9)
+               '(#\- #\. #\+))))
 (defparameter *reserved-nss-characters*
     (reserved-char-vector
      (append *excluded-characters* '(#\& #\~ #\/ #\?))))
 
 (defun parse-uri (thing &key (class 'uri) &aux escape)
   (when (uri-p thing) (return-from parse-uri thing))
-  
+
   (setq escape (escape-p thing))
   (multiple-value-bind (scheme host port path query fragment)
       (parse-uri-string thing)
     (when scheme
       (setq scheme
-       (intern (funcall
-                (case *current-case-mode*
-                  ((:case-insensitive-upper :case-sensitive-upper)
-                   #'string-upcase)
-                  ((:case-insensitive-lower :case-sensitive-lower)
-                   #'string-downcase))
-                (decode-escaped-encoding scheme escape))
-               (find-package :keyword))))
-    
+        (intern (funcall
+                 (case *current-case-mode*
+                   ((:case-insensitive-upper :case-sensitive-upper)
+                    #'string-upcase)
+                   ((:case-insensitive-lower :case-sensitive-lower)
+                    #'string-downcase))
+                 (decode-escaped-encoding scheme escape))
+                (find-package :keyword))))
+
     (when (and scheme (eq :urn scheme))
       (return-from parse-uri
-       (make-instance 'urn :scheme scheme :nid host :nss path)))
-    
+        (make-instance 'urn :scheme scheme :nid host :nss path)))
+
     (when host (setq host (decode-escaped-encoding host escape)))
     (when port
       (setq port (read-from-string port))
       (when (not (numberp port)) (error "port is not a number: ~s." port))
       (when (not (plusp port))
-       (error "port is not a positive integer: ~d." port))
+        (error "port is not a positive integer: ~d." port))
       (when (eql port (case scheme
-                     (:http 80)
-                     (:https 443)
-                     (:ftp 21)
-                     (:telnet 23)))
-       (setq port nil)))
+                      (:http 80)
+                      (:https 443)
+                      (:ftp 21)
+                      (:telnet 23)))
+        (setq port nil)))
     (when (or (string= "" path)
-             (and ;; we canonicalize away a reference to just /:
-              scheme
-              (member scheme '(:http :https :ftp) :test #'eq)
-              (string= "/" path)))
+              (and ;; we canonicalize away a reference to just /:
+               scheme
+               (member scheme '(:http :https :ftp) :test #'eq)
+               (string= "/" path)))
       (setq path nil))
     (when path
       (setq path
-       (decode-escaped-encoding path escape *reserved-path-characters*)))
+        (decode-escaped-encoding path escape *reserved-path-characters*)))
     (when query (setq query (decode-escaped-encoding query escape)))
     (when fragment
       (setq fragment
-       (decode-escaped-encoding fragment escape
-                                *reserved-fragment-characters*)))
+        (decode-escaped-encoding fragment escape
+                                 *reserved-fragment-characters*)))
     (if* (eq 'uri class)
        then ;; allow the compiler to optimize the make-instance call:
-           (make-instance 'uri
-             :scheme scheme
-             :host host
-             :port port
-             :path path
-             :query query
-             :fragment fragment
-             :escaped escape)
+            (make-instance 'uri
+              :scheme scheme
+              :host host
+              :port port
+              :path path
+              :query query
+              :fragment fragment
+              :escaped escape)
        else ;; do it the slow way:
-           (make-instance class
-             :scheme scheme
-             :host host
-             :port port
-             :path path
-             :query query
-             :fragment fragment
-             :escaped escape))))
+            (make-instance class
+              :scheme scheme
+              :host host
+              :port port
+              :path path
+              :query query
+              :fragment fragment
+              :escaped escape))))
 
 (defmethod uri ((thing uri))
   thing)
   ;;   (\?([^#]*))?
   ;;   (#(.*))?
   (let* ((state 0)
-        (start 0)
-        (end (length string))
-        (tokval nil)
-        (scheme nil)
-        (host nil)
-        (port nil)
-        (path-components '())
-        (query nil)
-        (fragment nil)
-        ;; namespace identifier, for urn parsing only:
-        (nid nil))
+         (start 0)
+         (end (length string))
+         (tokval nil)
+         (scheme nil)
+         (host nil)
+         (port nil)
+         (path-components '())
+         (query nil)
+         (fragment nil)
+         ;; namespace identifier, for urn parsing only:
+         (nid nil))
     (declare (fixnum state start end))
     (flet ((read-token (kind &optional legal-chars)
-            (setq tokval nil)
-            (if* (>= start end)
-               then :end
-               else (let ((sindex start)
-                          (res nil)
-                          c)
-                      (declare (fixnum sindex))
-                      (setq res
-                        (loop
-                          (when (>= start end) (return nil))
-                          (setq c (char string start))
-                          (let ((ci (char-int c)))
-                            (if* legal-chars
-                               then (if* (and (eq :colon kind) (eq c #\:))
-                                       then (return :colon)
-                                     elseif (= 0 (sbit legal-chars ci))
-                                       then (.parse-error
-                                             "~
+             (setq tokval nil)
+             (if* (>= start end)
+                then :end
+                else (let ((sindex start)
+                           (res nil)
+                           c)
+                       (declare (fixnum sindex))
+                       (setq res
+                         (loop
+                           (when (>= start end) (return nil))
+                           (setq c (char string start))
+                           (let ((ci (char-int c)))
+                             (if* legal-chars
+                                then (if* (and (eq :colon kind) (eq c #\:))
+                                        then (return :colon)
+                                      elseif (= 0 (sbit legal-chars ci))
+                                        then (.parse-error
+                                              "~
 URI ~s contains illegal character ~s at position ~d."
-                                             string c start))
-                             elseif (and (< ci 128)
-                                         *strict-parse*
-                                         (= 1 (sbit illegal-chars ci)))
-                               then (.parse-error "~
+                                              string c start))
+                              elseif (and (< ci 128)
+                                          *strict-parse*
+                                          (= 1 (sbit illegal-chars ci)))
+                                then (.parse-error "~
 URI ~s contains illegal character ~s at position ~d."
-                                                        string c start)))
-                          (case kind
-                            (:path (case c
-                                     (#\? (return :question))
-                                     (#\# (return :hash))))
-                            (:query (case c (#\# (return :hash))))
-                            (:rest)
-                            (t (case c
-                                 (#\: (return :colon))
-                                 (#\? (return :question))
-                                 (#\# (return :hash))
-                                 (#\/ (return :slash)))))
-                          (incf start)))
-                      (if* (> start sindex)
-                         then ;; we found some chars
-                              ;; before we stopped the parse
-                              (setq tokval (subseq string sindex start))
-                              :string
-                         else ;; immediately stopped at a special char
-                              (incf start)
-                              res))))
-          (failure (&optional why)
-            (.parse-error "illegal URI: ~s [~d]~@[: ~a~]"
-                                string state why))
-          (impossible ()
-            (.parse-error "impossible state: ~d [~s]" state string)))
+                                                         string c start)))
+                           (case kind
+                             (:path (case c
+                                      (#\? (return :question))
+                                      (#\# (return :hash))))
+                             (:query (case c (#\# (return :hash))))
+                             (:rest)
+                             (t (case c
+                                  (#\: (return :colon))
+                                  (#\? (return :question))
+                                  (#\# (return :hash))
+                                  (#\/ (return :slash)))))
+                           (incf start)))
+                       (if* (> start sindex)
+                          then ;; we found some chars
+                               ;; before we stopped the parse
+                               (setq tokval (subseq string sindex start))
+                               :string
+                          else ;; immediately stopped at a special char
+                               (incf start)
+                               res))))
+           (failure (&optional why)
+             (.parse-error "illegal URI: ~s [~d]~@[: ~a~]"
+                                 string state why))
+           (impossible ()
+             (.parse-error "impossible state: ~d [~s]" state string)))
       (loop
-       (case state
-         (0 ;; starting to parse
-          (ecase (read-token t)
-            (:colon (failure))
-            (:question (setq state 7))
-            (:hash (setq state 8))
-            (:slash (setq state 3))
-            (:string (setq state 1))
-            (:end (setq state 9))))
-         (1 ;; seen <token><special char>
-          (let ((token tokval))
-            (ecase (read-token t)
-              (:colon (setq scheme token)
-                      (if* (equalp "urn" scheme)
-                         then (setq state 15)
-                         else (setq state 2)))
-              (:question (push token path-components)
-                         (setq state 7))
-              (:hash (push token path-components)
-                     (setq state 8))
-              (:slash (push token path-components)
-                      (push "/" path-components)
-                      (setq state 6))
-              (:string (failure))
-              (:end (push token path-components)
-                    (setq state 9)))))
-         (2 ;; seen <scheme>:
-          (ecase (read-token t)
-            (:colon (failure))
-            (:question (setq state 7))
-            (:hash (setq state 8))
-            (:slash (setq state 3))
-            (:string (setq state 10))
-            (:end (setq state 9))))
-         (10 ;; seen <scheme>:<token>
-          (let ((token tokval))
-            (ecase (read-token t)
-              (:colon (failure))
-              (:question (push token path-components)
-                         (setq state 7))
-              (:hash (push token path-components)
-                     (setq state 8))
-              (:slash (push token path-components)
-                      (setq state 6))
-              (:string (failure))
-              (:end (push token path-components)
-                    (setq state 9)))))
-         (3 ;; seen / or <scheme>:/
-          (ecase (read-token t)
-            (:colon (failure))
-            (:question (push "/" path-components)
-                       (setq state 7))
-            (:hash (push "/" path-components)
-                   (setq state 8))
-            (:slash (setq state 4))
-            (:string (push "/" path-components)
-                     (push tokval path-components)
-                     (setq state 6))
-            (:end (push "/" path-components)
-                  (setq state 9))))
-         (4 ;; seen [<scheme>:]//
-          (ecase (read-token t)
-            (:colon (failure))
-            (:question (failure))
-            (:hash (failure))
-            (:slash
-             (if* (and (equalp "file" scheme)
-                       (null host))
-                then ;; file:///...
-                     (push "/" path-components)
-                     (setq state 6)
-                else (failure)))
-            (:string (setq host tokval)
-                     (setq state 11))
-            (:end (failure))))
-         (11 ;; seen [<scheme>:]//<host>
-          (ecase (read-token t)
-            (:colon (setq state 5))
-            (:question (setq state 7))
-            (:hash (setq state 8))
-            (:slash (push "/" path-components)
-                    (setq state 6))
-            (:string (impossible))
-            (:end (setq state 9))))
-         (5 ;; seen [<scheme>:]//<host>:
-          (ecase (read-token t)
-            (:colon (failure))
-            (:question (failure))
-            (:hash (failure))
-            (:slash (push "/" path-components)
-                    (setq state 6))
-            (:string (setq port tokval)
-                     (setq state 12))
-            (:end (failure))))
-         (12 ;; seen [<scheme>:]//<host>:[<port>]
-          (ecase (read-token t)
-            (:colon (failure))
-            (:question (setq state 7))
-            (:hash (setq state 8))
-            (:slash (push "/" path-components)
-                    (setq state 6))
-            (:string (impossible))
-            (:end (setq state 9))))
-         (6 ;; seen /
-          (ecase (read-token :path)
-            (:question (setq state 7))
-            (:hash (setq state 8))
-            (:string (push tokval path-components)
-                     (setq state 13))
-            (:end (setq state 9))))
-         (13 ;; seen path
-          (ecase (read-token :path)
-            (:question (setq state 7))
-            (:hash (setq state 8))
-            (:string (impossible))
-            (:end (setq state 9))))
-         (7 ;; seen ?
-          (setq illegal-chars
-            (if* *strict-parse*
-               then *strict-illegal-query-characters*
-               else *illegal-query-characters*))
-          (ecase (prog1 (read-token :query)
-                   (setq illegal-chars *illegal-characters*))
-            (:hash (setq state 8))
-            (:string (setq query tokval)
-                     (setq state 14))
-            (:end (setq state 9))))
-         (14 ;; query
-          (ecase (read-token :query)
-            (:hash (setq state 8))
-            (:string (impossible))
-            (:end (setq state 9))))
-         (8 ;; seen #
-          (ecase (read-token :rest)
-            (:string (setq fragment tokval)
-                     (setq state 9))
-            (:end (setq state 9))))
-         (9 ;; done
-          (return
-            (values
-             scheme host port
-             (apply #'concatenate 'string (nreverse path-components))
-             query fragment)))
-         ;; URN parsing:
-         (15 ;; seen urn:, read nid now
-          (case (read-token :colon *valid-nid-characters*)
-            (:string (setq nid tokval)
-                     (setq state 16))
-            (t (failure "missing namespace identifier"))))
-         (16 ;; seen urn:<nid>
-          (case (read-token t)
-            (:colon (setq state 17))
-            (t (failure "missing namespace specific string"))))
-         (17 ;; seen urn:<nid>:, rest is nss
-          (return (values scheme
-                          nid
-                          nil
-                          (progn
-                            (setq illegal-chars *reserved-nss-characters*)
-                            (read-token :rest)
-                            tokval))))
-         (t (.parse-error
-             "internal error in parse engine, wrong state: ~s." state)))))))
+        (case state
+          (0 ;; starting to parse
+           (ecase (read-token t)
+             (:colon (failure))
+             (:question (setq state 7))
+             (:hash (setq state 8))
+             (:slash (setq state 3))
+             (:string (setq state 1))
+             (:end (setq state 9))))
+          (1 ;; seen <token><special char>
+           (let ((token tokval))
+             (ecase (read-token t)
+               (:colon (setq scheme token)
+                       (if* (equalp "urn" scheme)
+                          then (setq state 15)
+                          else (setq state 2)))
+               (:question (push token path-components)
+                          (setq state 7))
+               (:hash (push token path-components)
+                      (setq state 8))
+               (:slash (push token path-components)
+                       (push "/" path-components)
+                       (setq state 6))
+               (:string (failure))
+               (:end (push token path-components)
+                     (setq state 9)))))
+          (2 ;; seen <scheme>:
+           (ecase (read-token t)
+             (:colon (failure))
+             (:question (setq state 7))
+             (:hash (setq state 8))
+             (:slash (setq state 3))
+             (:string (setq state 10))
+             (:end (setq state 9))))
+          (10 ;; seen <scheme>:<token>
+           (let ((token tokval))
+             (ecase (read-token t)
+               (:colon (failure))
+               (:question (push token path-components)
+                          (setq state 7))
+               (:hash (push token path-components)
+                      (setq state 8))
+               (:slash (push token path-components)
+                       (setq state 6))
+               (:string (failure))
+               (:end (push token path-components)
+                     (setq state 9)))))
+          (3 ;; seen / or <scheme>:/
+           (ecase (read-token t)
+             (:colon (failure))
+             (:question (push "/" path-components)
+                        (setq state 7))
+             (:hash (push "/" path-components)
+                    (setq state 8))
+             (:slash (setq state 4))
+             (:string (push "/" path-components)
+                      (push tokval path-components)
+                      (setq state 6))
+             (:end (push "/" path-components)
+                   (setq state 9))))
+          (4 ;; seen [<scheme>:]//
+           (ecase (read-token t)
+             (:colon (failure))
+             (:question (failure))
+             (:hash (failure))
+             (:slash
+              (if* (and (equalp "file" scheme)
+                        (null host))
+                 then ;; file:///...
+                      (push "/" path-components)
+                      (setq state 6)
+                 else (failure)))
+             (:string (setq host tokval)
+                      (setq state 11))
+             (:end (failure))))
+          (11 ;; seen [<scheme>:]//<host>
+           (ecase (read-token t)
+             (:colon (setq state 5))
+             (:question (setq state 7))
+             (:hash (setq state 8))
+             (:slash (push "/" path-components)
+                     (setq state 6))
+             (:string (impossible))
+             (:end (setq state 9))))
+          (5 ;; seen [<scheme>:]//<host>:
+           (ecase (read-token t)
+             (:colon (failure))
+             (:question (failure))
+             (:hash (failure))
+             (:slash (push "/" path-components)
+                     (setq state 6))
+             (:string (setq port tokval)
+                      (setq state 12))
+             (:end (failure))))
+          (12 ;; seen [<scheme>:]//<host>:[<port>]
+           (ecase (read-token t)
+             (:colon (failure))
+             (:question (setq state 7))
+             (:hash (setq state 8))
+             (:slash (push "/" path-components)
+                     (setq state 6))
+             (:string (impossible))
+             (:end (setq state 9))))
+          (6 ;; seen /
+           (ecase (read-token :path)
+             (:question (setq state 7))
+             (:hash (setq state 8))
+             (:string (push tokval path-components)
+                      (setq state 13))
+             (:end (setq state 9))))
+          (13 ;; seen path
+           (ecase (read-token :path)
+             (:question (setq state 7))
+             (:hash (setq state 8))
+             (:string (impossible))
+             (:end (setq state 9))))
+          (7 ;; seen ?
+           (setq illegal-chars
+             (if* *strict-parse*
+                then *strict-illegal-query-characters*
+                else *illegal-query-characters*))
+           (ecase (prog1 (read-token :query)
+                    (setq illegal-chars *illegal-characters*))
+             (:hash (setq state 8))
+             (:string (setq query tokval)
+                      (setq state 14))
+             (:end (setq state 9))))
+          (14 ;; query
+           (ecase (read-token :query)
+             (:hash (setq state 8))
+             (:string (impossible))
+             (:end (setq state 9))))
+          (8 ;; seen #
+           (ecase (read-token :rest)
+             (:string (setq fragment tokval)
+                      (setq state 9))
+             (:end (setq state 9))))
+          (9 ;; done
+           (return
+             (values
+              scheme host port
+              (apply #'concatenate 'string (nreverse path-components))
+              query fragment)))
+          ;; URN parsing:
+          (15 ;; seen urn:, read nid now
+           (case (read-token :colon *valid-nid-characters*)
+             (:string (setq nid tokval)
+                      (setq state 16))
+             (t (failure "missing namespace identifier"))))
+          (16 ;; seen urn:<nid>
+           (case (read-token t)
+             (:colon (setq state 17))
+             (t (failure "missing namespace specific string"))))
+          (17 ;; seen urn:<nid>:, rest is nss
+           (return (values scheme
+                           nid
+                           nil
+                           (progn
+                             (setq illegal-chars *reserved-nss-characters*)
+                             (read-token :rest)
+                             tokval))))
+          (t (.parse-error
+              "internal error in parse engine, wrong state: ~s." state)))))))
 
 (defun escape-p (string)
   (declare (optimize (speed 3)))
   (do* ((i 0 (1+ i))
-       (max (the fixnum (length string))))
+        (max (the fixnum (length string))))
       ((= i max) nil)
     (declare (fixnum i max))
     (when (char= #\% (char string i))
@@ -754,143 +754,143 @@ URI ~s contains illegal character ~s at position ~d."
 
 (defun parse-path (path-string escape)
   (do* ((xpath-list (delimited-string-to-list path-string #\/))
-       (path-list
-        (progn
-          (if* (string= "" (car xpath-list))
-             then (setf (car xpath-list) :absolute)
-             else (push :relative xpath-list))
-          xpath-list))
-       (pl (cdr path-list) (cdr pl))
-       segments)
+        (path-list
+         (progn
+           (if* (string= "" (car xpath-list))
+              then (setf (car xpath-list) :absolute)
+              else (push :relative xpath-list))
+           xpath-list))
+        (pl (cdr path-list) (cdr pl))
+        segments)
       ((null pl) path-list)
-    
+
     (if* (cdr (setq segments
-               (if* (string= "" (car pl))
-                  then '("")
-                  else (delimited-string-to-list (car pl) #\;))))
+                (if* (string= "" (car pl))
+                   then '("")
+                   else (delimited-string-to-list (car pl) #\;))))
        then ;; there is a param
-           (setf (car pl)
-             (mapcar #'(lambda (s)
-                         (decode-escaped-encoding s escape
-                                                  ;; decode all %xx:
-                                                  nil))
-                     segments))
+            (setf (car pl)
+              (mapcar #'(lambda (s)
+                          (decode-escaped-encoding s escape
+                                                   ;; decode all %xx:
+                                                   nil))
+                      segments))
        else ;; no param
-           (setf (car pl)
-             (decode-escaped-encoding (car segments) escape
-                                      ;; decode all %xx:
-                                      nil)))))
+            (setf (car pl)
+              (decode-escaped-encoding (car segments) escape
+                                       ;; decode all %xx:
+                                       nil)))))
 
 (defun decode-escaped-encoding (string escape
-                               &optional (reserved-chars
-                                          *reserved-characters*))
+                                &optional (reserved-chars
+                                           *reserved-characters*))
   ;; Return a string with the real characters.
   (when (null escape) (return-from decode-escaped-encoding string))
   (do* ((i 0 (1+ i))
-       (max (length string))
-       (new-string (copy-seq string))
-       (new-i 0 (1+ new-i))
-       ch ch2 chc chc2)
+        (max (length string))
+        (new-string (copy-seq string))
+        (new-i 0 (1+ new-i))
+        ch ch2 chc chc2)
       ((= i max)
        (shrink-vector new-string new-i))
     (if* (char= #\% (setq ch (char string i)))
        then (when (> (+ i 3) max)
-             (.parse-error
-              "Unsyntactic escaped encoding in ~s." string))
-           (setq ch (char string (incf i)))
-           (setq ch2 (char string (incf i)))
-           (when (not (and (setq chc (digit-char-p ch 16))
-                           (setq chc2 (digit-char-p ch2 16))))
-             (.parse-error
-              "Non-hexidecimal digits after %: %c%c." ch ch2))
-           (let ((ci (+ (* 16 chc) chc2)))
-             (if* (or (null reserved-chars)
-                      (> ci 127)       ; bug11527
-                      (= 0 (sbit reserved-chars ci)))
-                then ;; ok as is
-                     (setf (char new-string new-i)
-                       (code-char ci))
-                else (setf (char new-string new-i) #\%)
-                     (setf (char new-string (incf new-i)) ch)
-                     (setf (char new-string (incf new-i)) ch2)))
+              (.parse-error
+               "Unsyntactic escaped encoding in ~s." string))
+            (setq ch (char string (incf i)))
+            (setq ch2 (char string (incf i)))
+            (when (not (and (setq chc (digit-char-p ch 16))
+                            (setq chc2 (digit-char-p ch2 16))))
+              (.parse-error
+               "Non-hexidecimal digits after %: %c%c." ch ch2))
+            (let ((ci (+ (* 16 chc) chc2)))
+              (if* (or (null reserved-chars)
+                       (> ci 127)       ; bug11527
+                       (= 0 (sbit reserved-chars ci)))
+                 then ;; ok as is
+                      (setf (char new-string new-i)
+                        (code-char ci))
+                 else (setf (char new-string new-i) #\%)
+                      (setf (char new-string (incf new-i)) ch)
+                      (setf (char new-string (incf new-i)) ch2)))
        else (setf (char new-string new-i) ch))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; Printing
 
 (defun render-uri (uri stream
-                  &aux (escape (uri-escaped uri))
-                       (*print-pretty* nil))
+                   &aux (escape (uri-escaped uri))
+                        (*print-pretty* nil))
   (when (null (uri-string uri))
     (setf (uri-string uri)
       (let ((scheme (uri-scheme uri))
-           (host (uri-host uri))
-           (port (uri-port uri))
-           (path (uri-path uri))
-           (query (uri-query uri))
-           (fragment (uri-fragment uri)))
-       (concatenate 'string
-         (when scheme
-           (encode-escaped-encoding
-            (string-downcase ;; for upper case lisps
-             (symbol-name scheme))
-            *reserved-characters* escape))
-         (when scheme ":")
-         (when (or host (eq :file scheme)) "//")
-         (when host
-           (encode-escaped-encoding
-            host *reserved-authority-characters* escape))
-         (when port ":")
-         (when port
-           #-allegro (format nil "~D" port)
-           #+allegro (with-output-to-string (s)
-                       (excl::maybe-print-fast s port))
-           )
-         (when path
-           (encode-escaped-encoding path
-                                    nil
-                                    ;;*reserved-path-characters*
-                                    escape))
-         (when query "?")
-         (when query (encode-escaped-encoding query nil escape))
-         (when fragment "#")
-         (when fragment (encode-escaped-encoding fragment nil escape))))))
+            (host (uri-host uri))
+            (port (uri-port uri))
+            (path (uri-path uri))
+            (query (uri-query uri))
+            (fragment (uri-fragment uri)))
+        (concatenate 'string
+          (when scheme
+            (encode-escaped-encoding
+             (string-downcase ;; for upper case lisps
+              (symbol-name scheme))
+             *reserved-characters* escape))
+          (when scheme ":")
+          (when (or host (eq :file scheme)) "//")
+          (when host
+            (encode-escaped-encoding
+             host *reserved-authority-characters* escape))
+          (when port ":")
+          (when port
+            #-allegro (format nil "~D" port)
+            #+allegro (with-output-to-string (s)
+                        (excl::maybe-print-fast s port))
+            )
+          (when path
+            (encode-escaped-encoding path
+                                     nil
+                                     ;;*reserved-path-characters*
+                                     escape))
+          (when query "?")
+          (when query (encode-escaped-encoding query nil escape))
+          (when fragment "#")
+          (when fragment (encode-escaped-encoding fragment nil escape))))))
   (if* stream
      then (format stream "~a" (uri-string uri))
      else (uri-string uri)))
 
 (defun render-parsed-path (path-list escape)
   (do* ((res '())
-       (first (car path-list))
-       (pl (cdr path-list) (cdr pl))
-       (pe (car pl) (car pl)))
+        (first (car path-list))
+        (pl (cdr path-list) (cdr pl))
+        (pe (car pl) (car pl)))
       ((null pl)
        (when res (apply #'concatenate 'string (nreverse res))))
     (when (or (null first)
-             (prog1 (eq :absolute first)
-               (setq first nil)))
+              (prog1 (eq :absolute first)
+                (setq first nil)))
       (push "/" res))
     (if* (atom pe)
        then (push
-            (encode-escaped-encoding pe *reserved-path-characters* escape)
-            res)
+             (encode-escaped-encoding pe *reserved-path-characters* escape)
+             res)
        else ;; contains params
-           (push (encode-escaped-encoding
-                  (car pe) *reserved-path-characters* escape)
-                 res)
-           (dolist (item (cdr pe))
-             (push ";" res)
-             (push (encode-escaped-encoding
-                    item *reserved-path-characters* escape)
-                   res)))))
+            (push (encode-escaped-encoding
+                   (car pe) *reserved-path-characters* escape)
+                  res)
+            (dolist (item (cdr pe))
+              (push ";" res)
+              (push (encode-escaped-encoding
+                     item *reserved-path-characters* escape)
+                    res)))))
 
 (defun render-urn (urn stream
-                  &aux (*print-pretty* nil))
+                   &aux (*print-pretty* nil))
   (when (null (uri-string urn))
     (setf (uri-string urn)
       (let ((nid (urn-nid urn))
-           (nss (urn-nss urn)))
-       (concatenate 'string "urn:" nid ":" nss))))
+            (nss (urn-nss urn)))
+        (concatenate 'string "urn:" nid ":" nss))))
   (if* stream
      then (format stream "~a" (uri-string urn))
      else (uri-string urn)))
@@ -903,26 +903,26 @@ URI ~s contains illegal character ~s at position ~d."
   ;; Make a string as big as it possibly needs to be (3 times the original
   ;; size), and truncate it at the end.
   (do* ((max (length string))
-       (new-max (* 3 max)) ;; worst case new size
-       (new-string (make-string new-max))
-       (i 0 (1+ i))
-       (new-i -1)
-       c ci)
+        (new-max (* 3 max)) ;; worst case new size
+        (new-string (make-string new-max))
+        (i 0 (1+ i))
+        (new-i -1)
+        c ci)
       ((= i max)
        (shrink-vector new-string (incf new-i)))
     (setq ci (char-int (setq c (char string i))))
     (if* (or (null reserved-chars)
-            (> ci 127)
-            (= 0 (sbit reserved-chars ci)))
+             (> ci 127)
+             (= 0 (sbit reserved-chars ci)))
        then ;; ok as is
-           (incf new-i)
-           (setf (char new-string new-i) c)
+            (incf new-i)
+            (setf (char new-string new-i) c)
        else ;; need to escape it
-           (multiple-value-bind (q r) (truncate ci 16)
-             (setf (char new-string (incf new-i)) #\%)
-             (setf (char new-string (incf new-i)) (elt *escaped-encoding* q))
-             (setf (char new-string (incf new-i))
-               (elt *escaped-encoding* r))))))
+            (multiple-value-bind (q r) (truncate ci 16)
+              (setf (char new-string (incf new-i)) #\%)
+              (setf (char new-string (incf new-i)) (elt *escaped-encoding* q))
+              (setf (char new-string (incf new-i))
+                (elt *escaped-encoding* r))))))
 
 (defmethod print-object ((uri uri) stream)
   (if* *print-escape*
@@ -954,33 +954,33 @@ URI ~s contains illegal character ~s at position ~d."
   (tagbody
 ;;;; step 2
     (when (and (null (uri-parsed-path uri))
-              (null (uri-scheme uri))
-              (null (uri-host uri))
-              (null (uri-port uri))
-              (null (uri-query uri)))
+               (null (uri-scheme uri))
+               (null (uri-host uri))
+               (null (uri-port uri))
+               (null (uri-query uri)))
       (return-from merge-uris
-       (let ((new (copy-uri base :place place)))
-         (when (uri-query uri)
-           (setf (uri-query new) (uri-query uri)))
-         (when (uri-fragment uri)
-           (setf (uri-fragment new) (uri-fragment uri)))
-         new)))
-    
+        (let ((new (copy-uri base :place place)))
+          (when (uri-query uri)
+            (setf (uri-query new) (uri-query uri)))
+          (when (uri-fragment uri)
+            (setf (uri-fragment new) (uri-fragment uri)))
+          new)))
+
     (setq uri (copy-uri uri :place place))
 
 ;;;; step 3
     (when (uri-scheme uri)
       (return-from merge-uris uri))
     (setf (uri-scheme uri) (uri-scheme base))
-  
+
 ;;;; step 4
     (when (uri-host uri) (go :done))
     (setf (uri-host uri) (uri-host base))
     (setf (uri-port uri) (uri-port base))
-    
+
 ;;;; step 5
     (let ((p (uri-parsed-path uri)))
-      
+
       ;; bug13133:
       ;; The following form causes our implementation to be at odds with
       ;; RFC 2396, however this is apparently what was intended by the
@@ -989,76 +989,76 @@ URI ~s contains illegal character ~s at position ~d."
       ;; this:
 ;;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query
       (when (null p)
-       (setf (uri-path uri) (uri-path base))
-       (go :done))
-      
+        (setf (uri-path uri) (uri-path base))
+        (go :done))
+
       (when (and p (eq :absolute (car p)))
-       (when (equal '(:absolute "") p)
-         ;; Canonicalize the way parsing does:
-         (setf (uri-path uri) nil))
-       (go :done)))
-    
+        (when (equal '(:absolute "") p)
+          ;; Canonicalize the way parsing does:
+          (setf (uri-path uri) nil))
+        (go :done)))
+
 ;;;; step 6
     (let* ((base-path
-           (or (uri-parsed-path base)
-               ;; needed because we canonicalize away a path of just `/':
-               '(:absolute "")))
-          (path (uri-parsed-path uri))
-          new-path-list)
+            (or (uri-parsed-path base)
+                ;; needed because we canonicalize away a path of just `/':
+                '(:absolute "")))
+           (path (uri-parsed-path uri))
+           new-path-list)
       (when (not (eq :absolute (car base-path)))
-       (error "Cannot merge ~a and ~a, since latter is not absolute."
-              uri base))
+        (error "Cannot merge ~a and ~a, since latter is not absolute."
+               uri base))
 
       ;; steps 6a and 6b:
       (setq new-path-list
-       (append (butlast base-path)
-               (if* path then (cdr path) else '(""))))
+        (append (butlast base-path)
+                (if* path then (cdr path) else '(""))))
 
       ;; steps 6c and 6d:
       (let ((last (last new-path-list)))
-       (if* (atom (car last))
-          then (when (string= "." (car last))
-                 (setf (car last) ""))
-          else (when (string= "." (caar last))
-                 (setf (caar last) ""))))
+        (if* (atom (car last))
+           then (when (string= "." (car last))
+                  (setf (car last) ""))
+           else (when (string= "." (caar last))
+                  (setf (caar last) ""))))
       (setq new-path-list
-       (delete "." new-path-list :test #'(lambda (a b)
-                                           (if* (atom b)
-                                              then (string= a b)
-                                              else nil))))
+        (delete "." new-path-list :test #'(lambda (a b)
+                                            (if* (atom b)
+                                               then (string= a b)
+                                               else nil))))
 
       ;; steps 6e and 6f:
       (let ((npl (cdr new-path-list))
-           index tmp fix-tail)
-       (setq fix-tail
-         (string= ".." (let ((l (car (last npl))))
-                         (if* (atom l)
-                            then l
-                            else (car l)))))
-       (loop
-         (setq index
-           (position ".." npl
-                     :test #'(lambda (a b)
-                               (string= a
-                                        (if* (atom b)
-                                           then b
-                                           else (car b))))))
-         (when (null index) (return))
-         (when (= 0 index)
-           ;; The RFC says, in 6g, "that the implementation may handle
-           ;; this error by retaining these components in the resolved
-           ;; path, by removing them from the resolved path, or by
-           ;; avoiding traversal of the reference."  The examples in C.2
-           ;; imply that we should do the first thing (retain them), so
-           ;; that's what we'll do.
-           (return))
-         (if* (= 1 index)
-            then (setq npl (cddr npl))
-            else (setq tmp npl)
-                 (dotimes (x (- index 2)) (setq tmp (cdr tmp)))
-                 (setf (cdr tmp) (cdddr tmp))))
-       (setf (cdr new-path-list) npl)
-       (when fix-tail (setq new-path-list (nconc new-path-list '("")))))
+            index tmp fix-tail)
+        (setq fix-tail
+          (string= ".." (let ((l (car (last npl))))
+                          (if* (atom l)
+                             then l
+                             else (car l)))))
+        (loop
+          (setq index
+            (position ".." npl
+                      :test #'(lambda (a b)
+                                (string= a
+                                         (if* (atom b)
+                                            then b
+                                            else (car b))))))
+          (when (null index) (return))
+          (when (= 0 index)
+            ;; The RFC says, in 6g, "that the implementation may handle
+            ;; this error by retaining these components in the resolved
+            ;; path, by removing them from the resolved path, or by
+            ;; avoiding traversal of the reference."  The examples in C.2
+            ;; imply that we should do the first thing (retain them), so
+            ;; that's what we'll do.
+            (return))
+          (if* (= 1 index)
+             then (setq npl (cddr npl))
+             else (setq tmp npl)
+                  (dotimes (x (- index 2)) (setq tmp (cdr tmp)))
+                  (setf (cdr tmp) (cdddr tmp))))
+        (setf (cdr new-path-list) npl)
+        (when fix-tail (setq new-path-list (nconc new-path-list '("")))))
 
       ;; step 6g:
       ;; don't complain if new-path-list starts with `..'.  See comment
@@ -1066,12 +1066,12 @@ URI ~s contains illegal character ~s at position ~d."
 
       ;; step 6h:
       (when (or (equal '(:absolute "") new-path-list)
-               (equal '(:absolute) new-path-list))
-       (setq new-path-list nil))
+                (equal '(:absolute) new-path-list))
+        (setq new-path-list nil))
       (setf (uri-path uri)
-       (render-parsed-path new-path-list
-                           ;; don't know, so have to assume:
-                           t)))
+        (render-parsed-path new-path-list
+                            ;; don't know, so have to assume:
+                            t)))
 
 ;;;; step 7
    :done
@@ -1088,78 +1088,78 @@ URI ~s contains illegal character ~s at position ~d."
 
 (defmethod enough-uri ((uri uri) (base uri) &optional place)
   (let ((new-scheme nil)
-       (new-host nil)
-       (new-port nil)
-       (new-parsed-path nil))
+        (new-host nil)
+        (new-port nil)
+        (new-parsed-path nil))
 
     (when (or (and (uri-scheme uri)
-                  (not (equalp (uri-scheme uri) (uri-scheme base))))
-             (and (uri-host uri)
-                  (not (equalp (uri-host uri) (uri-host base))))
-             (not (equalp (uri-port uri) (uri-port base))))
+                   (not (equalp (uri-scheme uri) (uri-scheme base))))
+              (and (uri-host uri)
+                   (not (equalp (uri-host uri) (uri-host base))))
+              (not (equalp (uri-port uri) (uri-port base))))
       (return-from enough-uri uri))
 
     (when (null (uri-host uri))
       (setq new-host (uri-host base)))
     (when (null (uri-port uri))
       (setq new-port (uri-port base)))
-    
+
     (when (null (uri-scheme uri))
       (setq new-scheme (uri-scheme base)))
 
     ;; Now, for the hard one, path.
     ;; We essentially do here what enough-namestring does.
     (do* ((base-path (uri-parsed-path base))
-         (path (uri-parsed-path uri))
-         (bp base-path (cdr bp))
-         (p path (cdr p)))
-       ((or (null bp) (null p))
-        ;; If p is nil, that means we have something like
-        ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so
-        ;; new-parsed-path will be nil.
-        (when (null bp)
-          (setq new-parsed-path (copy-list p))
-          (when (not (symbolp (car new-parsed-path)))
-            (push :relative new-parsed-path))))
+          (path (uri-parsed-path uri))
+          (bp base-path (cdr bp))
+          (p path (cdr p)))
+        ((or (null bp) (null p))
+         ;; If p is nil, that means we have something like
+         ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so
+         ;; new-parsed-path will be nil.
+         (when (null bp)
+           (setq new-parsed-path (copy-list p))
+           (when (not (symbolp (car new-parsed-path)))
+             (push :relative new-parsed-path))))
       (if* (equal (car bp) (car p))
-        thenret ;; skip it
-        else (setq new-parsed-path (copy-list p))
-             (when (not (symbolp (car new-parsed-path)))
-               (push :relative new-parsed-path))
-             (return)))
-
-    (let ((new-path 
-          (when new-parsed-path
-            (render-parsed-path new-parsed-path
-                                ;; don't know, so have to assume:
-                                t)))
-         (new-query (uri-query uri))
-         (new-fragment (uri-fragment uri))
-         (new-plist (copy-list (uri-plist uri))))
+         thenret ;; skip it
+         else (setq new-parsed-path (copy-list p))
+              (when (not (symbolp (car new-parsed-path)))
+                (push :relative new-parsed-path))
+              (return)))
+
+    (let ((new-path
+           (when new-parsed-path
+             (render-parsed-path new-parsed-path
+                                 ;; don't know, so have to assume:
+                                 t)))
+          (new-query (uri-query uri))
+          (new-fragment (uri-fragment uri))
+          (new-plist (copy-list (uri-plist uri))))
       (if* (and (null new-scheme)
-               (null new-host)
-               (null new-port)
-               (null new-path)
-               (null new-parsed-path)
-               (null new-query)
-               (null new-fragment))
-        then ;; can't have a completely empty uri!
-             (copy-uri nil
-                       :class (class-of uri)
-                       :place place
-                       :path "/"
-                       :plist new-plist)
-        else (copy-uri nil
-                       :class (class-of uri)
-                       :place place
-                       :scheme new-scheme
-                       :host new-host
-                       :port new-port
-                       :path new-path
-                       :parsed-path new-parsed-path
-                       :query new-query
-                       :fragment new-fragment
-                       :plist new-plist)))))
+                (null new-host)
+                (null new-port)
+                (null new-path)
+                (null new-parsed-path)
+                (null new-query)
+                (null new-fragment))
+         then ;; can't have a completely empty uri!
+              (copy-uri nil
+                        :class (class-of uri)
+                        :place place
+                        :path "/"
+                        :plist new-plist)
+         else (copy-uri nil
+                        :class (class-of uri)
+                        :place place
+                        :scheme new-scheme
+                        :host new-host
+                        :port new-port
+                        :path new-path
+                        :parsed-path new-parsed-path
+                        :query new-query
+                        :fragment new-fragment
+                        :plist new-plist)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; support for interning URIs
@@ -1167,28 +1167,28 @@ URI ~s contains illegal character ~s at position ~d."
 (defun make-uri-space (&rest keys &key (size 777) &allow-other-keys)
   #+allegro
   (apply #'make-hash-table :size size
-        :hash-function 'uri-hash
-        :test 'uri= :values nil keys)
+         :hash-function 'uri-hash
+         :test 'uri= :values nil keys)
   #-allegro
   (apply #'make-hash-table :size size keys))
 
 (defun gethash-uri (uri table)
   #+allegro (gethash uri table)
-  #-allegro 
+  #-allegro
   (let* ((hash (uri-hash uri))
-        (existing (gethash hash table)))
+         (existing (gethash hash table)))
     (dolist (u existing)
       (when (uri= u uri)
-       (return-from gethash-uri (values u t))))
+        (return-from gethash-uri (values u t))))
     (values nil nil)))
 
 (defun puthash-uri (uri table)
   #+allegro (excl:puthash-key uri table)
-  #-allegro 
+  #-allegro
   (let ((existing (gethash (uri-hash uri) table)))
     (dolist (u existing)
       (when (uri= u uri)
-       (return-from puthash-uri u)))
+        (return-from puthash-uri u)))
     (setf (gethash (uri-hash uri) table)
       (cons uri existing))
     uri))
@@ -1198,12 +1198,12 @@ URI ~s contains illegal character ~s at position ~d."
   (if* (uri-hashcode uri)
      thenret
      else (setf (uri-hashcode uri)
-               (sxhash
-                #+allegro
-                (render-uri uri nil)
-                #-allegro
-                (string-downcase 
-                 (render-uri uri nil))))))
+                (sxhash
+                 #+allegro
+                 (render-uri uri nil)
+                 #-allegro
+                 (string-downcase
+                  (render-uri uri nil))))))
 
 (defvar *uris* (make-uri-space))
 
@@ -1224,16 +1224,16 @@ URI ~s contains illegal character ~s at position ~d."
   ;; port is elided.  Hmmmm.  This means that this function has to be
   ;; scheme dependent.  Grrrr.
   (let ((default-port (case (uri-scheme uri1)
-                       (:http 80)
-                       (:https 443)
-                       (:ftp 21)
-                       (:telnet 23))))
+                        (:http 80)
+                        (:https 443)
+                        (:ftp 21)
+                        (:telnet 23))))
     (and (equalp (uri-host uri1) (uri-host uri2))
-        (eql (or (uri-port uri1) default-port)
-             (or (uri-port uri2) default-port))
-        (string= (uri-path uri1) (uri-path uri2))
-        (string= (uri-query uri1) (uri-query uri2))
-        (string= (uri-fragment uri1) (uri-fragment uri2)))))
+         (eql (or (uri-port uri1) default-port)
+              (or (uri-port uri2) default-port))
+         (string= (uri-path uri1) (uri-path uri2))
+         (string= (uri-query uri1) (uri-query uri2))
+         (string= (uri-fragment uri1) (uri-fragment uri2)))))
 
 (defmethod uri= ((urn1 urn) (urn2 urn))
   (when (not (eq (uri-scheme urn1) (uri-scheme urn2)))
@@ -1245,21 +1245,21 @@ URI ~s contains illegal character ~s at position ~d."
   ;; Return t iff the nss values are the same.
   ;; %2c and %2C are equivalent.
   (when (or (null nss1) (null nss2)
-           (not (= (setq len (length nss1))
-                   (length nss2))))
+            (not (= (setq len (length nss1))
+                    (length nss2))))
     (return-from urn-nss-equal nil))
   (do* ((i 0 (1+ i))
-       (state :char)
-       c1 c2)
+        (state :char)
+        c1 c2)
       ((= i len) t)
     (setq c1 (char nss1 i))
     (setq c2 (char nss2 i))
     (ecase state
       (:char
        (if* (and (char= #\% c1) (char= #\% c2))
-         then (setq state :percent+1)
-       elseif (char/= c1 c2)
-         then (return nil)))
+          then (setq state :percent+1)
+        elseif (char/= c1 c2)
+          then (return nil)))
       (:percent+1
        (when (char-not-equal c1 c2) (return nil))
        (setq state :percent+2))
@@ -1284,35 +1284,35 @@ URI ~s contains illegal character ~s at position ~d."
      else (error "bad uri: ~s." uri)))
 
 (defmacro do-all-uris ((var &optional uri-space result-form)
-                      &rest forms
-                      &environment env)
+                       &rest forms
+                       &environment env)
   "do-all-uris (var [[uri-space] result-form])
-                   {declaration}* {tag | statement}*
+                    {declaration}* {tag | statement}*
 Executes the forms once for each uri with var bound to the current uri"
   (let ((f (gensym))
-       (g-ignore (gensym))
-       (g-uri-space (gensym))
-       (body (third (parse-body forms env))))
+        (g-ignore (gensym))
+        (g-uri-space (gensym))
+        (body (third (parse-body forms env))))
     `(let ((,g-uri-space (or ,uri-space *uris*)))
        (prog nil
-        (flet ((,f (,var &optional ,g-ignore)
-                 (declare (ignore-if-unused ,var ,g-ignore))
-                 (tagbody ,@body)))
-          (maphash #',f ,g-uri-space))
-        (return ,result-form)))))
+         (flet ((,f (,var &optional ,g-ignore)
+                  (declare (ignore-if-unused ,var ,g-ignore))
+                  (tagbody ,@body)))
+           (maphash #',f ,g-uri-space))
+         (return ,result-form)))))
 
 (defun sharp-u (stream chr arg)
   (declare (ignore chr arg))
   (let ((arg (read stream nil nil t)))
     (if *read-suppress*
-       nil
+        nil
       (if* (stringp arg)
-        then (parse-uri arg)
-        else
+         then (parse-uri arg)
+         else
 
-        (internal-reader-error
-         stream
-         "#u takes a string or list argument: ~s" arg)))))
+         (internal-reader-error
+          stream
+          "#u takes a string or list argument: ~s" arg)))))
 
 
 #+allegro
@@ -1346,29 +1346,29 @@ excl::
 (defun time-uri-module ()
   (declare (optimize (speed 3) (safety 0) (debug 0)))
   (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo")
-       (uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo"))
+        (uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo"))
     (gc t) (gc :tenure) (gc :tenure) (gc :tenure)
     (format t "~&;;; starting timing testing 1...~%")
     (time (dotimes (i 100000) (parse-uri uri)))
-    
+
     (gc t) (gc :tenure) (gc :tenure) (gc :tenure)
     (format t "~&;;; starting timing testing 2...~%")
     (let ((uri (parse-uri uri)))
       (time (dotimes (i 100000)
-             ;; forces no caching of the printed representation:
-             (setf (uri-string uri) nil)
-             (format nil "~a" uri))))
-    
+              ;; forces no caching of the printed representation:
+              (setf (uri-string uri) nil)
+              (format nil "~a" uri))))
+
     (gc t) (gc :tenure) (gc :tenure) (gc :tenure)
     (format t "~&;;; starting timing testing 3...~%")
     (time
      (progn
        (dotimes (i 100000) (parse-uri uri2))
        (let ((uri (parse-uri uri)))
-        (dotimes (i 100000)
-          ;; forces no caching of the printed representation:
-          (setf (uri-string uri) nil)
-          (format nil "~a" uri)))))))
+         (dotimes (i 100000)
+           ;; forces no caching of the printed representation:
+           (setf (uri-string uri) nil)
+           (format nil "~a" uri)))))))
 
 ;;******** reference output (ultra, modified 5.0.1):
 ;;; starting timing testing 1...
index 076b546..b5cbe37 100644 (file)
 
 (defmacro gen-test-forms ()
   (let ((res '())
-       (base-uri "http://a/b/c/d;p?q"))
+        (base-uri "http://a/b/c/d;p?q"))
 
     (dolist (x `(;; (relative-uri result base-uri compare-function)
 ;;;; RFC Appendix C.1 (normal examples)
-                ("g:h" "g:h" ,base-uri)
-                ("g" "http://a/b/c/g" ,base-uri)
-                ("./g" "http://a/b/c/g" ,base-uri)
-                ("g/" "http://a/b/c/g/" ,base-uri)
-                ("/g" "http://a/g" ,base-uri) 
-                ("//g" "http://g" ,base-uri) 
+                 ("g:h" "g:h" ,base-uri)
+                 ("g" "http://a/b/c/g" ,base-uri)
+                 ("./g" "http://a/b/c/g" ,base-uri)
+                 ("g/" "http://a/b/c/g/" ,base-uri)
+                 ("/g" "http://a/g" ,base-uri)
+                 ("//g" "http://g" ,base-uri)
                  ;; Following was changed from appendix C of RFC 2396
                  ;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query
-                #-ignore ("?y" "http://a/b/c/d;p?y" ,base-uri) 
-                #+ignore ("?y" "http://a/b/c/?y" ,base-uri) 
-                ("g?y" "http://a/b/c/g?y" ,base-uri)
-                ("#s" "http://a/b/c/d;p?q#s" ,base-uri) 
-                ("g#s" "http://a/b/c/g#s" ,base-uri) 
-                ("g?y#s" "http://a/b/c/g?y#s" ,base-uri)
-                (";x" "http://a/b/c/;x" ,base-uri) 
-                ("g;x" "http://a/b/c/g;x" ,base-uri) 
-                ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri)
-                ("." "http://a/b/c/" ,base-uri) 
-                ("./" "http://a/b/c/" ,base-uri) 
-                (".." "http://a/b/" ,base-uri) 
-                ("../" "http://a/b/" ,base-uri)
-                ("../g" "http://a/b/g" ,base-uri) 
-                ("../.." "http://a/" ,base-uri) 
-                ("../../" "http://a/" ,base-uri)
-                ("../../g" "http://a/g" ,base-uri)
+                 #-ignore ("?y" "http://a/b/c/d;p?y" ,base-uri)
+                 #+ignore ("?y" "http://a/b/c/?y" ,base-uri)
+                 ("g?y" "http://a/b/c/g?y" ,base-uri)
+                 ("#s" "http://a/b/c/d;p?q#s" ,base-uri)
+                 ("g#s" "http://a/b/c/g#s" ,base-uri)
+                 ("g?y#s" "http://a/b/c/g?y#s" ,base-uri)
+                 (";x" "http://a/b/c/;x" ,base-uri)
+                 ("g;x" "http://a/b/c/g;x" ,base-uri)
+                 ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri)
+                 ("." "http://a/b/c/" ,base-uri)
+                 ("./" "http://a/b/c/" ,base-uri)
+                 (".." "http://a/b/" ,base-uri)
+                 ("../" "http://a/b/" ,base-uri)
+                 ("../g" "http://a/b/g" ,base-uri)
+                 ("../.." "http://a/" ,base-uri)
+                 ("../../" "http://a/" ,base-uri)
+                 ("../../g" "http://a/g" ,base-uri)
 ;;;; RFC Appendix C.2 (abnormal examples)
-                ("" "http://a/b/c/d;p?q" ,base-uri) 
-                ("../../../g" "http://a/../g" ,base-uri)
-                ("../../../../g" "http://a/../../g" ,base-uri) 
-                ("/./g" "http://a/./g" ,base-uri) 
-                ("/../g" "http://a/../g" ,base-uri)
-                ("g." "http://a/b/c/g." ,base-uri) 
-                (".g" "http://a/b/c/.g" ,base-uri) 
-                ("g.." "http://a/b/c/g.." ,base-uri)
-                ("..g" "http://a/b/c/..g" ,base-uri) 
-                ("./../g" "http://a/b/g" ,base-uri) 
-                ("./g/." "http://a/b/c/g/" ,base-uri)
-                ("g/./h" "http://a/b/c/g/h" ,base-uri) 
-                ("g/../h" "http://a/b/c/h" ,base-uri) 
-                ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri)
-                ("g;x=1/../y" "http://a/b/c/y" ,base-uri) 
-                ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri)
-                ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri) 
-                ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri)
-                ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri) 
-                ("http:g" "http:g" ,base-uri)
+                 ("" "http://a/b/c/d;p?q" ,base-uri)
+                 ("../../../g" "http://a/../g" ,base-uri)
+                 ("../../../../g" "http://a/../../g" ,base-uri)
+                 ("/./g" "http://a/./g" ,base-uri)
+                 ("/../g" "http://a/../g" ,base-uri)
+                 ("g." "http://a/b/c/g." ,base-uri)
+                 (".g" "http://a/b/c/.g" ,base-uri)
+                 ("g.." "http://a/b/c/g.." ,base-uri)
+                 ("..g" "http://a/b/c/..g" ,base-uri)
+                 ("./../g" "http://a/b/g" ,base-uri)
+                 ("./g/." "http://a/b/c/g/" ,base-uri)
+                 ("g/./h" "http://a/b/c/g/h" ,base-uri)
+                 ("g/../h" "http://a/b/c/h" ,base-uri)
+                 ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri)
+                 ("g;x=1/../y" "http://a/b/c/y" ,base-uri)
+                 ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri)
+                 ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri)
+                 ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri)
+                 ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri)
+                 ("http:g" "http:g" ,base-uri)
 
-                ("foo/bar/baz.htm#foo"
-                 "http://a/b/foo/bar/baz.htm#foo"
-                 "http://a/b/c.htm")
-                ("foo/bar/baz.htm#foo"
-                 "http://a/b/foo/bar/baz.htm#foo"
-                 "http://a/b/")
-                ("foo/bar/baz.htm#foo"
-                 "http://a/foo/bar/baz.htm#foo"
-                 "http://a/b")
-                ("foo/bar;x;y/bam.htm"
-                 "http://a/b/c/foo/bar;x;y/bam.htm"
-                 "http://a/b/c/")))
+                 ("foo/bar/baz.htm#foo"
+                  "http://a/b/foo/bar/baz.htm#foo"
+                  "http://a/b/c.htm")
+                 ("foo/bar/baz.htm#foo"
+                  "http://a/b/foo/bar/baz.htm#foo"
+                  "http://a/b/")
+                 ("foo/bar/baz.htm#foo"
+                  "http://a/foo/bar/baz.htm#foo"
+                  "http://a/b")
+                 ("foo/bar;x;y/bam.htm"
+                  "http://a/b/c/foo/bar;x;y/bam.htm"
+                  "http://a/b/c/")))
       (push `(test (intern-uri ,(second x))
-                            (intern-uri (merge-uris (intern-uri ,(first x))
-                                                    (intern-uri ,(third x))))
-                            :test 'uri=)
-           res))
+                             (intern-uri (merge-uris (intern-uri ,(first x))
+                                                     (intern-uri ,(third x))))
+                             :test 'uri=)
+            res))
 
 ;;;; intern tests
     (dolist (x '(;; default port and specifying the default port are
-                ;; supposed to compare the same:
-                ("http://www.franz.com:80" "http://www.franz.com")
-                ("http://www.franz.com:80" "http://www.franz.com" eq)
-                ;; make sure they're `eq':
-                ("http://www.franz.com:80" "http://www.franz.com" eq)
-                ("http://www.franz.com" "http://www.franz.com" eq)
-                ("http://www.franz.com/foo" "http://www.franz.com/foo" eq)
-                ("http://www.franz.com/foo?bar"
-                 "http://www.franz.com/foo?bar" eq)
-                ("http://www.franz.com/foo?bar#baz"
-                 "http://www.franz.com/foo?bar#baz" eq)
-                ("http://WWW.FRANZ.COM" "http://www.franz.com" eq)
-                ("http://www.FRANZ.com" "http://www.franz.com" eq)
-                ("http://www.franz.com" "http://www.franz.com/" eq)
-                (;; %72 is "r", %2f is "/", %3b is ";"
-                 "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/"
-                 "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq)))
+                 ;; supposed to compare the same:
+                 ("http://www.franz.com:80" "http://www.franz.com")
+                 ("http://www.franz.com:80" "http://www.franz.com" eq)
+                 ;; make sure they're `eq':
+                 ("http://www.franz.com:80" "http://www.franz.com" eq)
+                 ("http://www.franz.com" "http://www.franz.com" eq)
+                 ("http://www.franz.com/foo" "http://www.franz.com/foo" eq)
+                 ("http://www.franz.com/foo?bar"
+                  "http://www.franz.com/foo?bar" eq)
+                 ("http://www.franz.com/foo?bar#baz"
+                  "http://www.franz.com/foo?bar#baz" eq)
+                 ("http://WWW.FRANZ.COM" "http://www.franz.com" eq)
+                 ("http://www.FRANZ.com" "http://www.franz.com" eq)
+                 ("http://www.franz.com" "http://www.franz.com/" eq)
+                 (;; %72 is "r", %2f is "/", %3b is ";"
+                  "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/"
+                  "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq)))
       (push `(test (intern-uri ,(second x))
-                            (intern-uri ,(first x))
-             :test ',(if (third x)
-                         (third x)
-                         'uri=))
-           res))
+                             (intern-uri ,(first x))
+              :test ',(if (third x)
+                          (third x)
+                          'uri=))
+            res))
 
 ;;;; parsing and equivalence tests
     (push `(test
-           (parse-uri "http://foo+bar?baz=b%26lob+bof")
-           (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof"))
-           :test 'uri=)
-         res)
+            (parse-uri "http://foo+bar?baz=b%26lob+bof")
+            (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof"))
+            :test 'uri=)
+          res)
     (push '(test
-           (parse-uri "http://www.foo.com")
-           (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end
-           :test 'uri=)
-         res)
+            (parse-uri "http://www.foo.com")
+            (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end
+            :test 'uri=)
+          res)
     (push `(test
-           "baz=b%26lob+bof"
-           (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof"))
-           :test 'string=)
-         res)
+            "baz=b%26lob+bof"
+            (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof"))
+            :test 'string=)
+          res)
     (push `(test
-           "baz=b%26lob+bof%3d"
-           (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d"))
-           :test 'string=)
-         res)
+            "baz=b%26lob+bof%3d"
+            (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d"))
+            :test 'string=)
+          res)
     (push
      `(test (parse-uri "xxx?%41") (parse-uri "xxx?A") :test 'uri=)
      res)
      res)
 
     (push `(test-error (parse-uri " ")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "foo ")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri " foo ")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "<foo")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "foo>")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "<foo>")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "%")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "foo%xyr")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "\"foo\"")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test "%20" (format nil "~a" (parse-uri "%20"))
-                          :test 'string=)
-         res)
+                           :test 'string=)
+          res)
     (push `(test "&" (format nil "~a" (parse-uri "%26"))
-                          :test 'string=)
-         res)
+                           :test 'string=)
+          res)
     (push
      `(test "foo%23bar" (format nil "~a" (parse-uri "foo%23bar"))
-                     :test 'string=)
+                      :test 'string=)
      res)
     (push
      `(test "foo%23bar#foobar"
-                     (format nil "~a" (parse-uri "foo%23bar#foobar"))
-                     :test 'string=)
+                      (format nil "~a" (parse-uri "foo%23bar#foobar"))
+                      :test 'string=)
      res)
     (push
      `(test "foo%23bar#foobar#baz"
-                     (format nil "~a" (parse-uri "foo%23bar#foobar#baz"))
-                     :test 'string=)
+                      (format nil "~a" (parse-uri "foo%23bar#foobar#baz"))
+                      :test 'string=)
      res)
     (push
      `(test "foo%23bar#foobar#baz"
-                     (format nil "~a" (parse-uri "foo%23bar#foobar%23baz"))
-                     :test 'string=)
+                      (format nil "~a" (parse-uri "foo%23bar#foobar%23baz"))
+                      :test 'string=)
      res)
     (push
      `(test "foo%23bar#foobar/baz"
-                     (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz"))
-                     :test 'string=)
+                      (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz"))
+                      :test 'string=)
      res)
     (push `(test-error (parse-uri "foobar??")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "foobar?foo?")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test "foobar?%3f"
-                          (format nil "~a" (parse-uri "foobar?%3f"))
-                          :test 'string=)
-         res)
+                           (format nil "~a" (parse-uri "foobar?%3f"))
+                           :test 'string=)
+          res)
     (push `(test
-           "http://foo/bAr;3/baz?baf=3"
-           (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3"))
-           :test 'string=)
-         res)
+            "http://foo/bAr;3/baz?baf=3"
+            (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3"))
+            :test 'string=)
+          res)
     (push `(test
-           '(:absolute ("/bAr" "3") "baz")
-           (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))
-           :test 'equal)
-         res)
+            '(:absolute ("/bAr" "3") "baz")
+            (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))
+            :test 'equal)
+          res)
     (push `(test
-           "/%2fbAr;3/baz"
-           (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")))
-             (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz"))
-             (uri-path u))
-           :test 'string=)
-         res)
+            "/%2fbAr;3/baz"
+            (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")))
+              (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz"))
+              (uri-path u))
+            :test 'string=)
+          res)
     (push `(test
-           "http://www.verada.com:8010/kapow?name=foo%3Dbar%25"
-           (format nil "~a"
-                   (parse-uri
-                    "http://www.verada.com:8010/kapow?name=foo%3Dbar%25"))
-           :test 'string=)
-         res)
+            "http://www.verada.com:8010/kapow?name=foo%3Dbar%25"
+            (format nil "~a"
+                    (parse-uri
+                     "http://www.verada.com:8010/kapow?name=foo%3Dbar%25"))
+            :test 'string=)
+          res)
     (push `(test
-           "ftp://parcftp.xerox.com/pub/pcl/mop/"
-           (format nil "~a"
-                   (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/"))
-           :test 'string=)
-         res)
+            "ftp://parcftp.xerox.com/pub/pcl/mop/"
+            (format nil "~a"
+                    (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/"))
+            :test 'string=)
+          res)
 
 ;;;; enough-uri tests
     (dolist (x `(("http://www.franz.com/foo/bar/baz.htm"
-                 "http://www.franz.com/foo/bar/"
-                 "baz.htm")
-                ("http://www.franz.com/foo/bar/baz.htm"
-                 "http://www.franz.com/foo/bar"
-                 "baz.htm")
-                ("http://www.franz.com:80/foo/bar/baz.htm"
-                 "http://www.franz.com:80/foo/bar"
-                 "baz.htm")
-                ("http:/foo/bar/baz.htm" "http:/foo/bar"  "baz.htm")
-                ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm")
-                ("/foo/bar/baz.htm" "/foo/bar"  "baz.htm")
-                ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm")
-                ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo")
-                ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo")
-                
-                ("http://www.dnai.com/~layer/foo.htm"
-                 "http://www.known.net"
-                 "http://www.dnai.com/~layer/foo.htm")
-                ("http://www.dnai.com/~layer/foo.htm"
-                 "http://www.dnai.com:8000/~layer/"
-                 "http://www.dnai.com/~layer/foo.htm")
-                ("http://www.dnai.com:8000/~layer/foo.htm"
-                 "http://www.dnai.com/~layer/"
-                 "http://www.dnai.com:8000/~layer/foo.htm")
-                ("http://www.franz.com"
-                 "http://www.franz.com"
-                 "/")))
+                  "http://www.franz.com/foo/bar/"
+                  "baz.htm")
+                 ("http://www.franz.com/foo/bar/baz.htm"
+                  "http://www.franz.com/foo/bar"
+                  "baz.htm")
+                 ("http://www.franz.com:80/foo/bar/baz.htm"
+                  "http://www.franz.com:80/foo/bar"
+                  "baz.htm")
+                 ("http:/foo/bar/baz.htm" "http:/foo/bar"  "baz.htm")
+                 ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm")
+                 ("/foo/bar/baz.htm" "/foo/bar"  "baz.htm")
+                 ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm")
+                 ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo")
+                 ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo")
+
+                 ("http://www.dnai.com/~layer/foo.htm"
+                  "http://www.known.net"
+                  "http://www.dnai.com/~layer/foo.htm")
+                 ("http://www.dnai.com/~layer/foo.htm"
+                  "http://www.dnai.com:8000/~layer/"
+                  "http://www.dnai.com/~layer/foo.htm")
+                 ("http://www.dnai.com:8000/~layer/foo.htm"
+                  "http://www.dnai.com/~layer/"
+                  "http://www.dnai.com:8000/~layer/foo.htm")
+                 ("http://www.franz.com"
+                  "http://www.franz.com"
+                  "/")))
       (push `(test (parse-uri ,(third x))
-                            (enough-uri (parse-uri ,(first x))
-                                        (parse-uri ,(second x)))
-                            :test 'uri=)
-           res))
-    
+                             (enough-uri (parse-uri ,(first x))
+                                         (parse-uri ,(second x)))
+                             :test 'uri=)
+            res))
+
 ;;;; urn tests, ideas of which are from rfc2141
     (let ((urn "urn:com:foo-the-bar"))
       (push `(test "com" (urn-nid (parse-uri ,urn))
-                            :test #'string=)
-           res)
+                             :test #'string=)
+            res)
       (push `(test "foo-the-bar" (urn-nss (parse-uri ,urn))
-                            :test #'string=)
-           res))
+                             :test #'string=)
+            res))
     (push `(test-error (parse-uri "urn:")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "urn:foo")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "urn:foo$")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "urn:foo_")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test-error (parse-uri "urn:foo:foo&bar")
-                                :condition-type 'uri-parse-error)
-         res)
+                                 :condition-type 'uri-parse-error)
+          res)
     (push `(test (parse-uri "URN:foo:a123,456")
-                          (parse-uri "urn:foo:a123,456")
-                          :test #'uri=)
-         res)
+                           (parse-uri "urn:foo:a123,456")
+                           :test #'uri=)
+          res)
     (push `(test (parse-uri "URN:foo:a123,456")
-                          (parse-uri "urn:FOO:a123,456")
-                          :test #'uri=)
-         res)
+                           (parse-uri "urn:FOO:a123,456")
+                           :test #'uri=)
+          res)
     (push `(test (parse-uri "urn:foo:a123,456")
-                          (parse-uri "urn:FOO:a123,456")
-                          :test #'uri=)
-         res)
+                           (parse-uri "urn:FOO:a123,456")
+                           :test #'uri=)
+          res)
     (push `(test (parse-uri "URN:FOO:a123%2c456")
-                          (parse-uri "urn:foo:a123%2C456")
-                          :test #'uri=)
-         res)
+                           (parse-uri "urn:foo:a123%2C456")
+                           :test #'uri=)
+          res)
     (push `(test
-           nil
-           (uri= (parse-uri "urn:foo:A123,456")
-                 (parse-uri "urn:FOO:a123,456")))
-         res)
+            nil
+            (uri= (parse-uri "urn:foo:A123,456")
+                  (parse-uri "urn:FOO:a123,456")))
+          res)
     (push `(test
-           nil
-           (uri= (parse-uri "urn:foo:A123,456")
-                 (parse-uri "urn:foo:a123,456")))
-         res)
+            nil
+            (uri= (parse-uri "urn:foo:A123,456")
+                  (parse-uri "urn:foo:a123,456")))
+          res)
     (push `(test
-           nil
-           (uri= (parse-uri "urn:foo:A123,456")
-                 (parse-uri "URN:foo:a123,456")))
-         res)
+            nil
+            (uri= (parse-uri "urn:foo:A123,456")
+                  (parse-uri "URN:foo:a123,456")))
+          res)
     (push `(test
-           nil
-           (uri= (parse-uri "urn:foo:a123%2C456")
-                 (parse-uri "urn:FOO:a123,456")))
-         res)
+            nil
+            (uri= (parse-uri "urn:foo:a123%2C456")
+                  (parse-uri "urn:FOO:a123,456")))
+          res)
     (push `(test
-           nil
-           (uri= (parse-uri "urn:foo:a123%2C456")
-                 (parse-uri "urn:foo:a123,456")))
-         res)
+            nil
+            (uri= (parse-uri "urn:foo:a123%2C456")
+                  (parse-uri "urn:foo:a123,456")))
+          res)
     (push `(test
-           nil
-           (uri= (parse-uri "URN:FOO:a123%2c456")
-                 (parse-uri "urn:foo:a123,456")))
-         res)
+            nil
+            (uri= (parse-uri "URN:FOO:a123%2c456")
+                  (parse-uri "urn:foo:a123,456")))
+          res)
     (push `(test
-           nil
-           (uri= (parse-uri "urn:FOO:a123%2c456")
-                 (parse-uri "urn:foo:a123,456")))
-         res)
+            nil
+            (uri= (parse-uri "urn:FOO:a123%2c456")
+                  (parse-uri "urn:foo:a123,456")))
+          res)
     (push `(test
-           nil
-           (uri= (parse-uri "urn:foo:a123%2c456")
-                 (parse-uri "urn:foo:a123,456")))
-         res)
-    
+            nil
+            (uri= (parse-uri "urn:foo:a123%2c456")
+                  (parse-uri "urn:foo:a123,456")))
+          res)
+
     (push `(test t
-                          (uri= (parse-uri "foo") (parse-uri "foo#")))
-         res)
-    
+                           (uri= (parse-uri "foo") (parse-uri "foo#")))
+          res)
+
     (push
      '(let ((puri::*strict-parse* nil))
        (test-no-error
-       (puri:parse-uri
-        "http://foo.com/bar?a=zip|zop")))
+        (puri:parse-uri
+         "http://foo.com/bar?a=zip|zop")))
      res)
     (push
      '(test-error
        (puri:parse-uri "http://foo.com/bar?a=zip|zop")
        :condition-type 'uri-parse-error)
      res)
-    
+
     (push
      '(let ((puri::*strict-parse* nil))
        (test-no-error
-       (puri:parse-uri
-        "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041")))
+        (puri:parse-uri
+         "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041")))
      res)
     (push
      '(test-error
        (puri:parse-uri
-       "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041")
+        "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041")
        :condition-type 'uri-parse-error)
      res)
-    
+
     (push
      '(let ((puri::*strict-parse* nil))
        (test-no-error
-       (puri:parse-uri
-        "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")))
+        (puri:parse-uri
+         "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")))
      res)
     (push
      '(test-error
        (puri:parse-uri
-       "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")
+        "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")
        :condition-type 'uri-parse-error)
      res)
-    
+
     `(progn ,@(nreverse res))))
 
 (defun do-tests ()