1.0.30.41: Octets support for ebcdic-us

[sbcl.git] / src / code / octets.lisp

diff --git a/src/code/octets.lisp b/src/code/octets.lisp
index f95bf76..4f725a7 100644 (file)
--- a/src/code/octets.lisp
+++ b/src/code/octets.lisp
@@ -135,26 +135,6 @@ one-past-the-end"
     (,definer aref (simple-array (unsigned-byte 8) (*)))
     (,definer sap-ref-8 system-area-pointer)))
 
-;;; maps into TO-SEQ from elements of FROM-SEQ via MAPPER.  MAPPER
-;;; returns two values: the number of elments stored in TO-SEQ, and
-;;; the number used up from FROM-SEQ.  MAPPER is responsible for
-;;; getting out if either sequence runs out of room.
-(declaim (inline varimap))
-(defun varimap (to-seq to-start to-end from-start from-end mapper)
-  (declare (optimize speed (safety 0))
-           (type array-range to-start to-end from-start from-end)
-           (type function mapper))
-  (loop with from-size of-type array-range = 0
-        and to-size of-type array-range = 0
-        for to-pos of-type array-range = to-start then (+ to-pos to-size)
-        for from-pos of-type array-range = from-start then (+ from-pos from-size)
-        while (and (< to-pos to-end)
-                   (< from-pos from-end))
-        do (multiple-value-bind (ts fs) (funcall mapper to-pos from-pos)
-             (setf to-size ts
-                   from-size fs))
-        finally (return (values to-seq to-pos from-pos))))
-
 ;;; FIXME: find out why the comment about SYMBOLICATE below is true
 ;;; and fix it, or else replace with SYMBOLICATE.
 ;;;
@@ -402,8 +382,9 @@ one-past-the-end"
   (macrolet ((ascii-bash ()
                '(let ((array (make-array (+ null-padding (- send sstart))
                                          :element-type '(unsigned-byte 8))))
-                 (loop for i from sstart below send
-                       do (setf (aref array i) (char-code (char string i))))
+                 (loop for i from 0
+                       and j from sstart below send
+                       do (setf (aref array i) (char-code (char string j))))
                  array)))
     (etypecase string
       ((simple-array character (*))
@@ -488,11 +469,11 @@ one-past-the-end"
                  (type ,type array)
                  (type array-range sstart send astart aend)
                  (function mapper))
-        (varimap string sstart send
-                 astart aend
-                 (lambda (spos apos)
-                   (setf (char string spos) (code-char (funcall mapper (,accessor array apos))))
-                   (values 1 1)))))))
+        (loop for spos from sstart below send
+           for apos from astart below aend
+           do (setf (char string spos)
+                    (code-char (funcall mapper (,accessor array apos))))
+           finally (return (values string spos apos)))))))
 (instantiate-octets-definition define-latin->string*)
 
 (defmacro define-latin1->string* (accessor type)
@@ -516,7 +497,7 @@ one-past-the-end"
 (defmacro define-latin->string (accessor type)
   (let ((name (make-od-name 'latin->string accessor)))
     `(progn
-      (declaim (inline latin->string))
+      (declaim (inline ,name))
       (defun ,name (array astart aend mapper)
         (declare (optimize speed (safety 0))
                  (type ,type array)
@@ -603,7 +584,7 @@ one-past-the-end"
                             ;; two-byte sequence `"initial (length 3)"
                             ;; "non-continuation"' -- `#xef #x32')
                             ;; signal only part of that sequence as
-                            ;; erronous.
+                            ;; erroneous.
                             (loop for i from 1 below (min len remaining-bytes)
                                   always (valid-secondary-p i))
                             (enough-bytes-left-p len)))
@@ -817,7 +798,8 @@ one-past-the-end"
   (declare (type (vector (unsigned-byte 8)) vector))
   (with-array-data ((vector vector)
                     (start start)
-                    (end (%check-vector-sequence-bounds vector start end)))
+                    (end end)
+                    :check-fill-pointer t)
     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
     (funcall (symbol-function (first (external-formats-funs external-format)))
              vector start end)))
@@ -827,7 +809,8 @@ one-past-the-end"
   (declare (type string string))
   (with-array-data ((string string)
                     (start start)
-                    (end (%check-vector-sequence-bounds string start end)))
+                    (end end)
+                    :check-fill-pointer t)
     (declare (type simple-string string))
     (funcall (symbol-function (second (external-formats-funs external-format)))
              string start end (if null-terminate 1 0))))