Prefix override in IP prefix functions.

* share/txr/stdlib/socket.tl (sys:str-inaddr-net-impl): New
argument weff. Overrides prefix. Bugfix here: we must
base the number of octets on the calculated width before
wextra is added to it.
(str-inaddr-net, str-inaddr6-net): New optional width
argument.

* txr.1: Documented.

2 files changed, 35 insertions, 14 deletions

diff --git a/share/txr/stdlib/socket.tl b/share/txr/stdlib/socket.tl
index e911a6a7..1c54c6eb 100644
--- a/share/txr/stdlib/socket.tl
+++ b/share/txr/stdlib/socket.tl
@@ -89,34 +89,35 @@
       `[@str]:@port`
       str)))
 
-(defun sys:str-inaddr-net-impl (addr wextra)
+(defun sys:str-inaddr-net-impl (addr wextra : weff)
   (let ((mask addr))
     (set mask (logior mask (ash mask 1)))
     (set mask (logior mask (ash mask 2)))
     (set mask (logior mask (ash mask 4)))
     (set mask (logior mask (ash mask 8)))
     (set mask (logior mask (ash mask 16)))
-    (let ((w (+ (- 32 (width (lognot mask 32))) wextra))
+    (let ((w (- 32 (width (lognot mask 32))))
           (d (logand addr #xFF))
           (c (logand (ash addr -8) #xFF))
           (b (logand (ash addr -16) #xFF))
-          (a         (ash addr -24)))
+          (a         (ash addr -24))
+          (we (or weff (+ w wextra))))
       (cond
         ((or (> a 255) (minusp a))
          (throwf 'eval-error "str-inaddr-net: ~a out of range for IPv4 address"
                  addr))
-        ((> w 24) `@a.@b.@c.@d/@w`)
-        ((> w 16) `@a.@b.@c/@w`)
-        ((> w 8) `@a.@b/@w`)
-        (t `@a/@w`)))))
+        ((> w 24) `@a.@b.@c.@d/@we`)
+        ((> w 16) `@a.@b.@c/@we`)
+        ((> w 8) `@a.@b/@we`)
+        (t `@a/@we`)))))
 
-(defun str-inaddr-net (addr)
-  (sys:str-inaddr-net-impl addr 0))
+(defun str-inaddr-net (addr : width)
+  (sys:str-inaddr-net-impl addr 0 width))
 
-(defun str-in6addr-net (addr)
+(defun str-in6addr-net (addr : width)
   (if (and (<= (width addr) 48)
            (= (ash addr -32) #xFFFF))
-    `::ffff:@(sys:str-inaddr-net-impl (logtrunc addr 32) 96)`
+    `::ffff:@(sys:str-inaddr-net-impl (logtrunc addr 32) 96 width)`
     (let ((mask addr))
       (set mask (logior mask (ash mask 1)))
       (set mask (logior mask (ash mask 2)))
@@ -140,4 +141,4 @@
                                        addr)))
              (cand-prefix [pieces 0..(trunc (+ w 15) 16)])
              (prefix (if (search cand-prefix '(0 0)) pieces cand-prefix)))
-        `@(sys:in6addr-condensed-text prefix)/@w`))))
+        `@(sys:in6addr-condensed-text prefix)/@(or width w)`))))
diff --git a/txr.1 b/txr.1
index fb51074f..0c00f7a7 100644
--- a/txr.1
+++ b/txr.1
@@ -37851,8 +37851,8 @@ pattern.
 
 .coNP Functions @ str-inaddr-net and @ str-in6addr-net
 .synb
-.mets (str-inaddr-net address)
-.mets (str-in6addr-net address)
+.mets (str-inaddr-net < address <> [ width ])
+.mets (str-in6addr-net < address <> [ width ])
 .syne
 .desc
 The functions
@@ -37863,6 +37863,26 @@ convert, respectively, IPv4 and IPv6 network prefix addresses to
 the "slash notation". For IPv6 addresses, the requirements of section
 2.3 of RFC 4291 are implemented. For IPv4, section 3.1 of RFC 4632 is followed.
 
+The condensed portion of the IP address is always determined by measuring
+the contiguous extent of all-zero bits in the least significant position
+of the address. For instance an IPv4 address which has at least 24 zero bits
+in the least significant position, so that the only nonzero bits are in the
+highest octet, is always condensed to a single decimal number: the value of
+the first octet.
+
+If the
+.meta width
+parameter is specified, then its value is incorporated into the returned
+textual notation as the width. No check is made whether this width is an
+integer large enough to "covers" all the nonzero bits in the address.
+
+If
+.meta width
+is omitted, then it is calculated as the number of bits in the address,
+excluding the contiguous all-zero bits in the least significant position:
+how many times the address can be shifted to the right before a 1 appears
+in the least significant bit.
+
 .SS* Web Programming Support
 
 .coNP Functions @ url-encode and @ url-decode