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)))
 
     (,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.
 ;;;
 ;;; 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))))
   (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 (*))
                  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))
                  (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)
 (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
 (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)
       (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
                             ;; 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)))
                             (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)
   (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)))
     (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)
   (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))))
     (declare (type simple-string string))
     (funcall (symbol-function (second (external-formats-funs external-format)))
              string start end (if null-terminate 1 0))))