Changeset 36564 in project


Ignore:
Timestamp:
09/08/18 20:22:32 (2 weeks ago)
Author:
sjamaan
Message:

uri-generic: Port packrat parser to CHICKEN 5 and fix several bugs in it

Location:
release/5/uri-generic/trunk/alternatives
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/uri-generic/trunk/alternatives/uri-generic.comparse.scm

    r36555 r36564  
    118118                   (if (eq? key 'host) value new-host)
    119119                   (if (eq? key 'host)
    120                        (is-ipv6-host? value)
     120                       (and value (is-ipv6-host? value))
    121121                       new-ipv6-host?)
    122122                   (if (eq? key 'port) value new-port)))))))
     
    611611    (result (make-URIAuth (and ui (alist-ref 'user ui))
    612612                          (and ui (alist-ref 'pass ui))
    613                           host (is-ipv6-host? host) port))))
     613                          host (and host (is-ipv6-host? host)) port))))
    614614
    615615;; RFC3986, section 3
  • release/5/uri-generic/trunk/alternatives/uri-generic.irregex.scm

    r36553 r36564  
    123123                   (if (eq? key 'host) value new-host)
    124124                   (if (eq? key 'host)
    125                        (is-ipv6-host? value)
     125                       (and value (is-ipv6-host? value))
    126126                       new-ipv6-host?)
    127127                   (if (eq? key 'port) value new-port)))))))
     
    484484                    (make-URIAuth
    485485                     user pass
    486                      host (is-ipv6-host? host)
     486                     host (and host (is-ipv6-host? host))
    487487                     (and port (string->number port)))))
    488488             path (irregex-match-substring m 'query)
  • release/5/uri-generic/trunk/alternatives/uri-generic.matchable.scm

    r36551 r36564  
    158158                   (if (eq? key 'host) value new-host)
    159159                   (if (eq? key 'host)
    160                        (is-ipv6-host? value)
     160                       (and value (is-ipv6-host? value))
    161161                       new-ipv6-host?)
    162162                   (if (eq? key 'port) value new-port)))))))
     
    560560        (and uw (uri-char-list->string uw))
    561561        host
    562         (is-ipv6-host? host)
     562        (and host (is-ipv6-host? host))
    563563        (and (pair? up) (string->number (list->string up))))
    564564       rst))))
  • release/5/uri-generic/trunk/alternatives/uri-generic.packrat.scm

    r33642 r36564  
    11;; uri-generic version based on packrat
    2 
    3 (provide 'uri-generic)
    42
    53(module uri-generic
    64  (uri-reference make-uri update-uri update-authority
    75   uri-reference? uri-auth uri-authority uri-scheme uri-path uri-query
    8    uri-fragment uri-host uri-port uri-username uri-password
    9    authority? authority-host authority-port
     6   uri-fragment uri-host uri-ipv6-host? uri-port
     7   uri-username uri-password
     8   authority? authority-host authority-ipv6-host? authority-port
    109   authority-username authority-password
    1110   
     
    1918   char-set:uri-reserved char-set:uri-unreserved)
    2019
    21 (import chicken scheme)
    22 (use extras data-structures ports irregex
    23      srfi-1 srfi-4 srfi-13 srfi-14 packrat)
    24 
     20(import scheme (chicken base) (chicken string) (chicken port)
     21        (chicken format) (chicken irregex) (chicken condition)
     22        srfi-14 packrat)
    2523
    2624(define uri-error error)
     
    4038;; What to do with these?
    4139;; #;(cond-expand
    42 ;;    (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
    43 ;;    (else (use srfi-13 srfi-14)))
     40;;    (utf8-strings (use utf8-srfi-14))
     41;;    (else (use srfi-14)))
    4442
    4543(define-record-type <URI>
     
    5351
    5452(define-record-type <URIAuth>
    55   (make-URIAuth username password host port)
     53  (make-URIAuth username password host ipv6-host? port)
    5654  URIAuth?
    5755  (username URIAuth-username URIAuth-username-set!)
    5856  (password URIAuth-password URIAuth-password-set!)
    5957  (host URIAuth-host URIAuth-host-set!)
     58  (ipv6-host? URIAuth-ipv6-host? URIAuth-ipv6-host?-set!)
    6059  (port URIAuth-port URIAuth-port-set!))
    6160
     
    7271 
    7372  (define-record-printer (<URIAuth> x out)
    74     (fprintf out "#(URIAuth host=~S port=~A)"
     73    (fprintf out "#(URIAuth host=~S~A port=~A)"
    7574             (URIAuth-host x)
     75             (if (URIAuth-ipv6-host? x) "(ipv6)" "")
    7676             (URIAuth-port x))))
    7777 (else))
     
    100100
    101101
     102(define (is-ipv6-host? h) (and (substring-index ":" h) #t))
     103
    102104(define (update-URIAuth uri-auth . args)
    103105  (let loop ((args args)
     
    105107             (new-password (URIAuth-password uri-auth))
    106108             (new-host (URIAuth-host uri-auth))
     109             (new-ipv6-host? (URIAuth-ipv6-host? uri-auth))
    107110             (new-port (URIAuth-port uri-auth)))
    108111    (cond ((null? args)
    109            (make-URIAuth new-username new-password new-host new-port))
     112           (make-URIAuth new-username new-password
     113                         new-host new-ipv6-host? new-port))
    110114          ((null? (cdr args))
    111115           (uri-error "malformed arguments to update-URIAuth"))
     
    117121                   (if (eq? key 'password) value new-password)
    118122                   (if (eq? key 'host) value new-host)
     123                   (if (eq? key 'host)
     124                       (and value (is-ipv6-host? value))
     125                       new-ipv6-host?)
    119126                   (if (eq? key 'port) value new-port)))))))
    120127
     
    133140    (and auth (URIAuth-host auth))))
    134141
     142(define (uri-ipv6-host? x)
     143  (let ((auth (URI-authority x)))
     144    (and auth (URIAuth-ipv6-host? auth))))
     145
    135146(define (uri-port x)
    136147  (let ((auth (URI-authority x)))
     
    147158(define authority? URIAuth?)
    148159(define authority-host URIAuth-host)
     160(define authority-ipv6-host? URIAuth-ipv6-host?)
    149161(define authority-port URIAuth-port)
    150162(define authority-username URIAuth-username)
     
    170182                            ((not (eq? unset authority)) authority)
    171183                            (else (URI-authority uri)))
    172                              (make-URIAuth #f #f #f #f)))
     184                             (make-URIAuth #f #f #f #f #f)))
    173185                 (updated-auth (apply update-authority base-auth args))
    174                  (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f)
     186                 (final-auth (if (uri-auth-equal? (make-URIAuth #f #f #f #f #f)
    175187                                                  updated-auth)
    176188                               #f
     
    325337           ,(and-let* ((auth (URI-authority uri))
    326338                       (host (URIAuth-host auth)))
    327               (let ((username (URIAuth-username auth)))
    328                 (list "//" (and username (list (userinfomap username (URIAuth-password auth)) "@"))
    329                       host (and (URIAuth-port auth)
    330                                 (list ":" (URIAuth-port auth))))))
     339              (let ((username (URIAuth-username auth))
     340                    (password (URIAuth-password auth))
     341                    (ipv6? (URIAuth-ipv6-host? auth))
     342                    (port (URIAuth-port auth)))
     343                (list "//" (and username (list (userinfomap
     344                                                username
     345                                                password) "@"))
     346                      (if ipv6? "[" "") host (if ipv6? "]" "")
     347                      (and port (list ":" port)))))
    331348           ,(path->string (uri-path uri))
    332349           ,(and-let* ((query (uri-query uri))) (list "?" query))
     
    340357
    341358(define uri-decode-string
    342   (let ((re (irregex `(seq #\% hex-digit hex-digit))))
     359  (let ((re (irregex `(seq #\% (submatch-named num hex-digit hex-digit)))))
    343360    (lambda (str #!optional (char-set char-set:full))
    344361      (irregex-replace/all
    345362       re str
    346363       (lambda (match)
    347          (let* ((encoded (irregex-match-substring match))
    348                 (decoded (integer->char (string->number (string-drop encoded 1) 16))))
    349            (if (char-set-contains? char-set decoded) (string decoded) encoded)))))))
     364         (let* ((encoded (irregex-match-substring match 'num))
     365                (decoded (integer->char (string->number encoded 16))))
     366           (if (char-set-contains? char-set decoded)
     367               (string decoded)
     368               (irregex-match-substring match))))))))
    350369
    351370(define (display-fragments b)
     
    379398
    380399;; Section 4.2; if the first segment contains a colon, it must be prefixed "./"
    381 (define (protect? sa) (string-index sa #\:))
     400(define (protect? sa) (substring-index ":" sa))
    382401
    383402; specific: ((uri-authority uri) (uri-path uri) (uri-query uri)).
     
    398417
    399418(define (uri-normalize-case uri)
    400   (let* ((normalized-uri (uri-reference
     419  (let* ((downcase (lambda (s)
     420                     (list->string (map char-downcase (string->list s)))))
     421         (normalized-uri (uri-reference
    401422                          (normalize-pct-encoding (uri->string uri (lambda (user pass) (conc user ":" pass))))))
    402          (scheme         (string->symbol (string-downcase (->string (uri-scheme uri)))))
    403          (host           (normalize-pct-encoding (string-downcase (uri-host uri)))))
     423         (scheme         (string->symbol (downcase (->string (uri-scheme uri)))))
     424         (host           (normalize-pct-encoding (downcase (uri-host uri)))))
    404425    (update-uri* normalized-uri 'scheme scheme 'host host)))
    405426
     
    412433  (define (hex-digit i)
    413434    (and (>= i 0) (< i 16)
    414          (car (string->list (string-upcase (number->string i 16))))))
     435         (char-upcase (string-ref (number->string i 16) 0))))
    415436  (define (pct-encode c)
    416437    (let ((i (char->integer c)))
    417438     `(#\% ,(hex-digit (quotient i 16)) ,(hex-digit (remainder i 16)))))
    418439  (list->string
    419    (string-fold-right (lambda (c res)
    420                         (if (char-set-contains? char-set c)
    421                             (append (pct-encode c) res)
    422                             (cons c res)))
    423                       '() str)))
     440   (foldr (lambda (c res)
     441            (if (char-set-contains? char-set c)
     442                (append (pct-encode c) res)
     443                (cons c res)))
     444          '() (string->list str))))
    424445
    425446(define normalize-pct-encoding
    426   (let ((re (irregex `(seq #\% hex-digit hex-digit)))
     447  (let ((re (irregex `(seq #\% (submatch-named num hex-digit hex-digit))))
    427448        (char-set char-set:uri-unreserved))
    428449    (lambda (str)
    429       (irregex-replace/all
    430        re str
    431        (lambda (match)
    432          (let* ((encoded (irregex-match-substring match))
    433                 (decoded (integer->char (string->number (string-drop encoded 1) 16))))
    434            (if (char-set-contains? char-set decoded)
    435                (string decoded)
    436                (string-upcase encoded))))))))
     450     (irregex-replace/all
     451      re str
     452      (lambda (match)
     453        (let* ((encoded (irregex-match-substring match 'num))
     454               (decoded (integer->char (string->number encoded 16))))
     455          (if (char-set-contains? char-set:uri-unreserved decoded)
     456              (string decoded)
     457              (string #\%
     458                      (char-upcase (string-ref encoded 0))
     459                      (char-upcase (string-ref encoded 1))))))))))
    437460
    438461(define path-safe-chars (char-set-union char-set:uri-unreserved (char-set #\/ #\?)))
    439 
    440 (define (match->uri m)
    441   (let* ((ap (or (irregex-match-substring m 'abspath1)
    442                  (irregex-match-substring m 'abspath2)))
    443          (rp (or (irregex-match-substring m 'relpath1)
    444                  (irregex-match-substring m 'relpath2)))
    445          (path (if ap
    446                    (if (string-null? ap)
    447                        '()
    448                        (cons '/ (map (lambda (s)
    449                                        (uri-decode-string s path-safe-chars))
    450                                      (cdr (string-split ap "/" #t)))))
    451                    (if (string-null? rp)
    452                        '()
    453                        (map (lambda (s)
    454                               (uri-decode-string s path-safe-chars))
    455                             (string-split rp "/" #t))))))
    456    (make-URI (handle-exceptions
    457                  exn #f
    458                (and-let* ((s (irregex-match-substring m 'scheme)))
    459                  (string->symbol s)))
    460              (let ((user (irregex-match-substring m 'username))
    461                    (pass (irregex-match-substring m 'password))
    462                    (host (irregex-match-substring m 'host))
    463                    (port (irregex-match-substring m 'port)))
    464                (and (or user pass host port)
    465                     (make-URIAuth
    466                      user pass host (and port (string->number port)))))
    467              path
    468              (irregex-match-substring m 'query)
    469              (irregex-match-substring m 'fragment))))
    470462
    471463;; RFC3986, section 3.2.2
     
    484476(define hex-digit (char-set-parser char-set:hex-digit))
    485477
     478;; ucs-range->char-set is inclusive lower, exclusive upper bound!
    486479(define x31-39
    487   (char-set-parser (char-set (integer->char #x31) (integer->char #x39))))
     480  (char-set-parser (ucs-range->char-set #x31 #x40)))
    488481(define x30-34
    489   (char-set-parser (char-set (integer->char #x30) (integer->char #x34))))
     482  (char-set-parser (ucs-range->char-set #x30 #x35)))
    490483(define x30-35
    491   (char-set-parser (char-set (integer->char #x30) (integer->char #x35))))
     484  (char-set-parser (ucs-range->char-set #x30 #x36)))
    492485
    493486(define scheme-chars (char-set-parser (char-set-union char-set:letter+digit
     
    509502   (pct-encoded (('#\% h1 <- hex-digit h2 <- hex-digit) `(#\% ,h1 ,h2)))
    510503
    511    (dec-octet ((n <- numeric) n)
     504  ;; Reordered from RFC's ABNF to avoid nongreedy match on single numeric
     505   (dec-octet (('#\2 '#\5 n <- x30-35) `(#\2 #\5 ,n))
     506              (('#\2 n1 <- x30-34 n2 <- numeric) `(#\2 ,n1 ,n2))
     507              (('#\1 n1 <- numeric n2 <- numeric) `(#\1 ,n1 ,n2))
    512508              ((n1 <- x31-39 n2 <- numeric) `(,n1 ,n2))
    513               (('#\1 n1 <- numeric n2 <- numeric) `(#\1 ,n1 ,n2))
    514               (('#\2 n1 <- x30-34 n2 <- numeric) `(#\2 ,n1 ,n2))
    515               (('#\2 '#\5 n <- x30-35) `(#\2 #\5 ,n)))
    516 
    517    (ipv4-address ((n1 <- dec-octet '#\. n2 <- dec-octet '#\. n3 <- dec-octet '#\.)
    518                   (append! n1 '(#\.) n2 '(#\.) n3)))
     509              ((n <- numeric) `(,n)))
     510
     511   (ipv4-address ((n1 <- dec-octet '#\. n2 <- dec-octet '#\. n3 <- dec-octet '#\. n4 <- dec-octet)
     512                  (append n1 '(#\.) n2 '(#\.) n3 '(#\.) n4)))
    519513
    520514   ;; IPv6address =                                  6( h16 ":" ) ls32
     
    535529
    536530   (h16  ((n1 <- hex-digit n2 <- hex-digit n3 <- hex-digit n4 <- hex-digit)
    537           `(,n1 ,n2 ,n3 ,n4)))
    538    (ls32 ((n1 <- h16 '#\: n2 <- h16) (append! n1 '(#\:) n2))
     531          `(,n1 ,n2 ,n3 ,n4))
     532         ((n1 <- hex-digit n2 <- hex-digit n3 <- hex-digit)
     533          `(,n1 ,n2 ,n3))
     534         ((n1 <- hex-digit n2 <- hex-digit) `(,n1 ,n2))
     535         ((n1 <- hex-digit) `(,n1)))
     536
     537   (ls32 ((n1 <- h16 '#\: n2 <- h16) (append n1 '(#\:) n2))
    539538         ((a <- ipv4-address) a))
    540539
     540   ;; Negative-lookahead on :: to prevent greedy match
     541   (h16-colon ((hex <- h16 (! '#\: '#\:)) hex))
     542
     543   ;; Like above, we don't want to consume ls32 at the end
     544   (h16-colon-no-ls32 ((hex <- h16 '#\: (! '#\: h16)) hex))
     545
    541546   (h16:x6 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:
    542              n4 <- h16 '#\: n5 <- h16 '#\: n6 <- h16 '#\:)
    543             `(,n1 #\: ,n2 #\: ,n3 #\: ,n4 #\: n5 #\: n6 #\:)))
     547             n4 <- h16 '#\: n5 <- h16 '#\: n6 <- h16-colon '#\:)
     548            `(,@n1 #\: ,@n2 #\: ,@n3 #\: ,@n4 #\: ,@n5 #\: ,@n6 #\:)))
    544549
    545550   (h16:x5 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:
    546              n4 <- h16 '#\: n5 <- h16 '#\:)
    547             `(,n1 #\: ,n2 #\: ,n3 #\: ,n4 #\: n5 #\:)))
    548 
    549    (h16:x4 ((n1 <- h16 '#\: n2 <- h16 #\: n3 <- h16 #\: n4 <- h16 #\:)
    550             `(,n1 #\: ,n2 #\: ,n3 #\: ,n4 #\:)))
    551 
    552    (h16:x3 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:)
    553             `(,n1 #\: ,n2 #\: ,n3 #\:)))
    554 
    555    (h16:x2 ((n1 <- h16 '#\: n2 <- h16 '#\:) `(,n1 #\: ,n2 #\:)))
    556 
    557    (h16:x1 ((n1 <- h16 '#\:) `(,n1 #\:)))
    558 
    559    (h16? ((n <- h16) n) (() '()))
    560    (h16:x1-h16? ((n1 <- h16:x1 n2 <- h16) (append! n1 n2)) (() '()))
    561    (h16:x2-h16? ((n1 <- h16:x2 n2 <- h16) (append! n1 n2)) (() '()))
    562    (h16:x3-h16? ((n1 <- h16:x3 n2 <- h16) (append! n1 n2)) (() '()))
    563    (h16:x4-h16? ((n1 <- h16:x4 n2 <- h16) (append! n1 n2)) (() '()))
    564    (h16:x5-h16? ((n1 <- h16:x5 n2 <- h16) (append! n1 n2)) (() '()))
    565    (h16:x6-h16? ((n1 <- h16:x6 n2 <- h16) (append! n1 n2)) (() '()))
    566    
    567    (ipv6-address ((n1 <- h16 n2 <- ls32)
    568                   (append! n1 n2))
     551             n4 <- h16 '#\: n5 <- h16-colon '#\:)
     552            `(,@n1 #\: ,@n2 #\: ,@n3 #\: ,@n4 #\: ,@n5 #\:)))
     553
     554   (h16:x4 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16 '#\:
     555             n4 <- h16-colon '#\:)
     556            `(,@n1 #\: ,@n2 #\: ,@n3 #\: ,@n4 #\:)))
     557
     558   (h16:x3 ((n1 <- h16 '#\: n2 <- h16 '#\: n3 <- h16-colon '#\:)
     559            `(,@n1 #\: ,@n2 #\: ,@n3 #\:)))
     560
     561   (h16:x2 ((n1 <- h16 '#\: n2 <- h16-colon '#\:) `(,@n1 #\: ,@n2 #\:)))
     562
     563   (h16:x1 ((n1 <- h16-colon '#\:) `(,@n1 #\:)))
     564
     565   (h16-colon? ((n <- h16-colon) n) (() '()))
     566   (h16:x1-h16-colon? ((n1 <- h16:x1 n2 <- h16) (append n1 n2))
     567                      ((n1 <- h16) n1)
     568                      (() '()))
     569   (h16:x2-h16-colon? ((n1 <- h16:x2 n2 <- h16) (append n1 n2))
     570                      ((n1 <- h16:x1-h16-colon?) n1))
     571   (h16:x3-h16-colon? ((n1 <- h16:x3 n2 <- h16) (append n1 n2))
     572                      ((n1 <- h16:x2-h16-colon?) n1))
     573   (h16:x4-h16-colon? ((n1 <- h16:x4 n2 <- h16) (append n1 n2))
     574                      ((n1 <- h16:x3-h16-colon?) n1))
     575   (h16:x5-h16-colon? ((n1 <- h16:x5 n2 <- h16) (append n1 n2))
     576                      ((n1 <- h16:x4-h16-colon?) n1))
     577   (h16:x6-h16-colon? ((n1 <- h16:x6 n2 <- h16) (append n1 n2))
     578                      ((n1 <- h16:x5-h16-colon?) n1))
     579
     580   (ipv6-address ((n1 <- h16:x6 n2 <- ls32)
     581                  (append n1 n2))
    569582                 (('#\: '#\: n1 <- h16:x5 n2 <- ls32)
    570583                  `(#\: #\: ,@n1 ,@n2))
    571                  ((n1 <- h16? '#\: '#\: n2 <- h16:x4 n3 <- ls32)
     584                 ((n1 <- h16-colon? '#\: '#\: n2 <- h16:x4 n3 <- ls32)
    572585                  `(,@n1 #\: #\: ,@n2 ,@n3))
    573                  ((n1 <- h16:x1-h16? '#\: '#\: n2 <- h16:x3 n3 <- ls32)
     586                 ((n1 <- h16:x1-h16-colon? '#\: '#\: n2 <- h16:x3 n3 <- ls32)
    574587                  `(,@n1 #\: #\: ,@n2 ,@n3))
    575                  ((n1 <- h16:x2-h16? '#\: '#\: n2 <- h16:x2 n3 <- ls32)
     588                 ((n1 <- h16:x2-h16-colon? '#\: '#\: n2 <- h16:x2 n3 <- ls32)
    576589                  `(,@n1 #\: #\: ,@n2 ,@n3))
    577                  ((n1 <- h16:x3-h16? '#\: '#\: n2 <- h16:x1 n3 <- ls32)
     590                 ((n1 <- h16:x3-h16-colon? '#\: '#\: n2 <- h16:x1 n3 <- ls32)
    578591                  `(,@n1 #\: #\: ,@n2 ,@n3))
    579                  ((n1 <- h16:x4-h16? '#\: '#\: n2 <- ls32)
     592                 ((n1 <- h16:x4-h16-colon? '#\: '#\: n2 <- ls32)
    580593                  `(,@n1 #\: #\: ,@n2))
    581                  ((n1 <- h16:x5-h16? '#\: '#\: n2 <- h16)
     594                 ((n1 <- h16:x5-h16-colon? '#\: '#\: n2 <- h16)
    582595                  `(,@n1 #\: #\: ,@n2))
    583                  ((n1 <- h16:x6-h16? '#\: '#\:)
     596                 ((n1 <- h16:x6-h16-colon? '#\: '#\:)
    584597                  `(,@n1 #\: #\:)))
    585598
    586599   ;; IPvFuture  = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )
    587600   (ipv-future (('#\v n1 <- hex-digits '#\. n2 <- ipv-future-rest)
     601                (print `(#\v ,@n1 #\. ,@n2))
    588602                `(#\v ,@n1 #\. ,@n2)))
    589603   (hex-digits ((n1 <- hex-digit n2 <- hex-digit n3 <- hex-digits)
    590604                (cons n1 (cons n2 n3)))
    591605               ((n1 <- hex-digit) `(,n1)))
    592    (ipv-future-rest ((n1 <- unres-sub-: n2 <- unres-sub: n3 <- ipv-future-rest)
    593                      (cons n1 (cons n2 n3)))
    594                     ((n1 <- unres-sub-:) `(,n1)))
    595    (unres-sub-: ((n1 <- unreserved) n1) ((n2 <- sub-delims) n2) ((#\:) #\:))
     606   (ipv-future-rest ((n1 <- unres-sub-colon n2 <- ipv-future-rest)
     607                     (cons n1 n2))
     608                    (() '()))
     609   (unres-sub-colon ((n1 <- unreserved) n1)
     610                    ((n2 <- sub-delims) n2)
     611                    (('#\:) #\:))
     612
    596613
    597614   ;; IP-literal = "[" ( IPv6address / IPvFuture  ) "]"
    598    (ip-literal (('#\[ a <- ipv6-address '#\]) `(#\[ ,@a #\]))
    599                (('#\[ a <- ipv-future   '#\]) `(#\[ ,@a #\])))
     615   (ip-literal (('#\[ a <- ipv6-address '#\]) a)
     616               (('#\[ a <- ipv-future   '#\]) a))
    600617
    601618   (reg-name ((r1 <- unreserved  r2 <- reg-name) (cons r1 r2))
    602619             ((r1 <- pct-encoded r2 <- reg-name)
    603               (append! (pct-decode r1 char-set:uri-unreserved) r2))
     620              (append (pct-decode r1 char-set:uri-unreserved) r2))
    604621             ((r1 <- sub-delims  r2 <- reg-name) (cons r1 r2))
    605622             (() '()))
     
    634651   (userinfo0 ((u <- unreserved ur <- userinfo0)  (cons u ur))
    635652              ((u <- pct-encoded ur <- userinfo0)
    636                (append! (pct-decode u char-set:uri-unreserved) ur))
     653               (append (pct-decode u char-set:uri-unreserved) ur))
    637654              ((u <- sub-delims ur <- userinfo0)  (cons u ur))
    638655              (() '()))
     
    640657   (userinfo1 ((u <- unreserved ur <- userinfo1)  (cons u ur))
    641658              ((u <- pct-encoded ur <- userinfo1)
    642                (append! (pct-decode u char-set:uri-unreserved) ur))
     659               (append (pct-decode u char-set:uri-unreserved) ur))
    643660              ((u <- sub-delims ur <- userinfo1)  (cons u ur))
    644661              (('#\: ur <- userinfo1) (cons #\: ur))
     
    656673                (() #f))
    657674   (authority ((ui <- userinfo@? h <- host p <- :port?)
    658                (make-URIAuth (car ui) (cdr ui) h p)))
     675               (make-URIAuth (car ui) (cdr ui) h
     676                             (and h (is-ipv6-host? h)) p)))
    659677
    660678   ;; RFC3986, section 3
     
    695713             (('#\@) `(#\@)))
    696714
    697    (segment ((p <- pchar s <- segment) (append! p s))
     715   (segment ((p <- pchar s <- segment) (append p s))
    698716            (() '()))
    699    (segment-nz ((p <- pchar s <- segment-nz) (append! p s))
     717   (segment-nz ((p <- pchar s <- segment-nz) (append p s))
    700718               ((p <- pchar) p))
    701    (segment-nz-nc ((p <- pchar-nc s <- segment-nz-nc) (append! p s))
     719   (segment-nz-nc ((p <- pchar-nc s <- segment-nz-nc) (append p s))
    702720                  ((p <- pchar-nc) p))
    703721
     
    745763   ;;
    746764   ;; fragment       = *( pchar / "/" / "?" )
    747    (fragment ((c <- qchar r <- fragment) (append! c r))
     765   (fragment ((c <- qchar r <- fragment) (append c r))
    748766             (('#\/ r <- fragment) (cons #\/ r))
    749767             (('#\? r <- fragment) (cons #\? r))
Note: See TracChangeset for help on using the changeset viewer.