Instanciated a babel::*string-vector-mappings* that accept STRINGs (and not just SIMPLE-STRINGs). Simplified REPLACE-OCTETS-BY-STRING.

Pascal J. Bourguignon [2021-05-23 08:18]
Instanciated a babel::*string-vector-mappings* that accept STRINGs (and not just SIMPLE-STRINGs).  Simplified REPLACE-OCTETS-BY-STRING.
Filename
clext/telnet/babel-extension-test.lisp
clext/telnet/babel-extension.lisp
diff --git a/clext/telnet/babel-extension-test.lisp b/clext/telnet/babel-extension-test.lisp
index eb1cc0a..c066ddd 100644
--- a/clext/telnet/babel-extension-test.lisp
+++ b/clext/telnet/babel-extension-test.lisp
@@ -5,9 +5,9 @@
 ;;;;SYSTEM:             Common-Lisp
 ;;;;USER-INTERFACE:     NONE
 ;;;;DESCRIPTION
-;;;;
+;;;;
 ;;;;    Tests decode-character.
-;;;;
+;;;;
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
@@ -15,23 +15,28 @@
 ;;;;BUGS
 ;;;;LEGAL
 ;;;;    AGPL3
-;;;;
+;;;;
 ;;;;    Copyright Pascal J. Bourguignon 2021 - 2021
-;;;;
+;;;;
 ;;;;    This program is free software: you can redistribute it and/or modify
 ;;;;    it under the terms of the GNU Affero General Public License as published by
 ;;;;    the Free Software Foundation, either version 3 of the License, or
 ;;;;    (at your option) any later version.
-;;;;
+;;;;
 ;;;;    This program is distributed in the hope that it will be useful,
 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;;;    GNU Affero General Public License for more details.
-;;;;
+;;;;
 ;;;;    You should have received a copy of the GNU Affero General Public License
 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************

+(defpackage "COM.INFORMATIMAGO.CLEXT.BABEL-EXTENSION.TEST"
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.CLEXT.BABEL-EXTENSION"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST")
+  (:export "TEST/ALL"))
 (in-package "COM.INFORMATIMAGO.CLEXT.BABEL-EXTENSION.TEST")


@@ -203,7 +208,7 @@
     (check equal (multiple-value-list (decode-character (replace octets #(#b11000000 #b11100001)) :encoding encoding))
            '(nil nil 2)
            (encoding octets))
-
+
     (check equal (multiple-value-list (decode-character (replace octets #(#b11100000 #b10110011 #b00100001)) :encoding encoding))
            '(nil nil 3)
            (encoding octets))
@@ -240,7 +245,7 @@
       :for (character validp size) := (multiple-value-list (decode-character octets :start start :encoding encoding))
       :do (assert-true character (character) "decode-character should have decoded a ~S character from ~A" encoding start)
           (assert-true validp (validp) "decode-character should have decoded a valid ~S code sequence from ~A" encoding start)
-          (check char= character expected (encoding start octets character expected))
+          (check char= character expected (encoding start octets character expected))
       :finally (incf start size)
                (check = start (length octets) (encoding start octets)))))

@@ -254,6 +259,3 @@

 ;; (test/all)
 ;;;; THE END ;;;;
-
-
-
diff --git a/clext/telnet/babel-extension.lisp b/clext/telnet/babel-extension.lisp
index 6971f9b..19dbb12 100644
--- a/clext/telnet/babel-extension.lisp
+++ b/clext/telnet/babel-extension.lisp
@@ -5,9 +5,9 @@
 ;;;;SYSTEM:             Common-Lisp
 ;;;;USER-INTERFACE:     NONE
 ;;;;DESCRIPTION
-;;;;
+;;;;
 ;;;;    A function to test for code sequences.
-;;;;
+;;;;
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
@@ -15,19 +15,19 @@
 ;;;;BUGS
 ;;;;LEGAL
 ;;;;    AGPL3
-;;;;
+;;;;
 ;;;;    Copyright Pascal J. Bourguignon 2021 - 2021
-;;;;
+;;;;
 ;;;;    This program is free software: you can redistribute it and/or modify
 ;;;;    it under the terms of the GNU Affero General Public License as published by
 ;;;;    the Free Software Foundation, either version 3 of the License, or
 ;;;;    (at your option) any later version.
-;;;;
+;;;;
 ;;;;    This program is distributed in the hope that it will be useful,
 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;;;    GNU Affero General Public License for more details.
-;;;;
+;;;;
 ;;;;    You should have received a copy of the GNU Affero General Public License
 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************
@@ -145,14 +145,14 @@ For example, in the case NIL T len, if len <= (- end start), then it means the g
 ;; (defparameter *replacement-character*
 ;;   (if (<= 65535 char-code-limit)        ; does it really mean that the
 ;;                                         ; implementation uses unicode?
-;;
+;;
 ;;       (code-char 65533)                 ; #\Replacement_Character
-;;
+;;
 ;;       ;; Let's assume ASCII:
 ;;       (code-char 26)                    ; #\Sub
 ;;       ;; SUB is #x3f  in EBCDIC
 ;;       )
-;;
+;;
 ;;   "A replacement character.")


@@ -263,6 +263,16 @@ For example, in the case NIL T len, if len <= (- end start), then it means the g
            (values nil nil 1) #|???|#))))))


+(defparameter babel::*string-vector-mappings*
+  (babel::instantiate-concrete-mappings
+   ;; :optimize ((speed 3) (safety 0) (debug 0) (compilation-speed 0))
+   :octet-seq-setter babel::ub-set
+   :octet-seq-getter babel::ub-get
+   :octet-seq-type (vector (unsigned-byte 8) *)
+   :code-point-seq-setter babel::string-set
+   :code-point-seq-getter babel::string-get
+   :code-point-seq-type babel::unicode-string))
+

 (defun replace-octets-by-string (octets string &key (encoding *default-character-encoding*)
                                                  (use-bom :default)
@@ -271,60 +281,25 @@ For example, in the case NIL T len, if len <= (- end start), then it means the g
                                                  (errorp (not babel::*suppress-character-coding-errors*))
                                                  (error-on-out-of-space-p t))
   (declare (optimize (speed 3) (safety 2)))
-  (let ((babel::*suppress-character-coding-errors* (not errorp))
-        (end1 (or end1 (length octets))))
-    (etypecase string
-      ;; On some lisps (e.g. clisp and ccl) all strings are BASE-STRING and all
-      ;; characters are BASE-CHAR. So, only enable this optimization for
-      ;; selected targets.
-      #+sbcl
-      (simple-base-string
-       (unless end2
-         (setf end2 (length string)))
-       (babel::check-vector-bounds string start2 end2)
-       (let* ((mapping (babel::lookup-mapping babel::*simple-base-string-vector-mappings*
-                                              encoding))
-              (bom (babel::bom-vector encoding use-bom))
-              (bom-length (length bom))
-              ;; OPTIMIZE: we could use the (length string) information here
-              ;; because it's a simple-base-string where each character <= 127
-              (octet-count (funcall (the function (babel::octet-counter mapping))
-                                    string start2 end2 -1)))
-         (if (< (- end1 start1) (+ bom-length octet-count))
-             (if error-on-out-of-space-p
-                 (error "Not enough space in destination octets vector; needed ~D bytes, available ~D bytes."
-                        (+ bom-length octet-count)
-                        (- end1 start1))
-                 (values nil (+ start1 bom-length octet-count)))
-             (progn
-               (replace octets bom :start1 start1)
-               (funcall (the function (babel::encoder mapping))
-                        string start2 end2 octets (+ start1 bom-length))
-               (values octets (+ start1 bom-length octet-count))))))
-      (string
-       ;; FIXME: we shouldn't really need that coercion to UNICODE-STRING
-       ;; but we kind of because it's declared all over.  To avoid that,
-       ;; we'd need different types for input and output strings.  Or maybe
-       ;; this is not a problem; figure that out.
-       (babel::with-checked-simple-vector ((string (coerce string 'unicode-string))
-                                           (start2 start2) (end2 end2))
-         (declare (type babel::simple-unicode-string string))
-         (let* ((mapping (babel::lookup-mapping babel::*string-vector-mappings* encoding))
-                (bom (babel::bom-vector encoding use-bom))
-                (bom-length (length bom))
-                (octet-count (funcall (the function (babel::octet-counter mapping))
-                                      string start2 end2 -1)))
-           (if (< (- end1 start1) (+ bom-length octet-count))
-               (if error-on-out-of-space-p
-                   (error "Not enough space in destination octets vector; needed ~D bytes, available ~D bytes."
-                          (+ bom-length octet-count)
-                          (- end1 start1))
-                   (values nil (+ start1 bom-length octet-count)))
-               (progn
-                 (replace octets bom :start1 start1)
-                 (funcall (the function (babel::encoder mapping))
-                          string start2 end2 octets (+ start1 bom-length))
-                 (values octets (+ start1 bom-length octet-count))))))))))
+  (let* ((babel::*suppress-character-coding-errors* (not errorp))
+         (end1 (or end1 (length octets)))
+         (end2 (or end2 (length string)))
+         (mapping (babel::lookup-mapping babel::*string-vector-mappings* encoding))
+         (bom (babel::bom-vector encoding use-bom))
+         (bom-length (length bom))
+         (octet-count (funcall (the function (babel::octet-counter mapping))
+                               string start2 end2 -1)))
+    (if (< (- end1 start1) (+ bom-length octet-count))
+        (if error-on-out-of-space-p
+            (error "Not enough space in destination octets vector; needed ~D bytes, available ~D bytes."
+                   (+ bom-length octet-count)
+                   (- end1 start1))
+            (values nil (+ start1 bom-length octet-count)))
+        (progn
+          (replace octets bom :start1 start1)
+          (funcall (the function (babel::encoder mapping))
+                   string start2 end2 octets (+ start1 bom-length))
+          (values octets (+ start1 bom-length octet-count))))))


 ;;;; THE END ;;;;
ViewGit