<commit_before>;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-unicode.lisp --- Unicode encodings.
;;;
;;; Copyright (C) 2007, <NAME>  <<EMAIL>>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.

;;; This implementation is largely based on OpenMCL's l1-unicode.lisp
;;;   Copyright (C) 2006 Clozure Associates and contributors.

(in-package #:babel-encodings)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +repl+ #xfffd "Unicode replacement character code point.")
  (defconstant +byte-order-mark-code+ #xfeff)
  (defconstant +swapped-byte-order-mark-code+ #xfffe)
  (defconstant +swapped-byte-order-mark-code-32+ #xfffe0000))

;;; Some convenience macros adding FIXNUM declarations.
(defmacro f-ash (integer count) `(the fixnum (ash ,integer ,count)))
(defmacro f-logior (&rest integers) `(the fixnum (logior ,@integers)))
(defmacro f-logand (&rest integers) `(the fixnum (logand ,@integers)))
(defmacro f-logxor (&rest integers) `(the fixnum (logxor ,@integers)))

;;;; UTF-8

(define-character-encoding :utf-8
    "An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 to 4 bytes."
  :max-units-per-char 4
  :literal-char-code-limit #x80
  :bom-encoding #(#xef #xbb #xbf)
  :default-replacement #xfffd)

(define-octet-counter :utf-8 (getter type)
  `(lambda (seq start end max)
     (declare (type ,type seq) (fixnum start end max))
     (loop with noctets fixnum = 0
           for i fixnum from start below end
           for code of-type code-point = (,getter seq i) do
           (let ((new (+ (cond ((< code #x80) 1)
                               ((< code #x800) 2)
                               ((< code #x10000) 3)
                               (t 4))
                         noctets)))
             (if (and (plusp max) (> new max))
                 (loop-finish)
                 (setq noctets new)))
           finally (return (values noctets i)))))

(define-code-point-counter :utf-8 (getter type)
  `(lambda (seq start end max)
     (declare (type ,type seq) (fixnum start end max))
     (loop with nchars fixnum = 0
           with i fixnum = start
           while (< i end) do
           ;; wrote this code with LET instead of FOR because CLISP's
           ;; LOOP doesn't like WHILE clauses before FOR clauses.
           (let* ((octet (,getter seq i))
                  (next-i (+ i (cond ((< octet #x80) 1)
                                     ((< octet #xe0) 2)
                                     ((< octet #xf0) 3)
                                     (t 4)))))
             (declare (type ub8 octet) (fixnum next-i))
             (cond
               ((> next-i end)
                ;; If this error is suppressed, we return the length
                ;; calculated so far and the decoder won't see an
                ;; END-OF-INPUT-IN-CHARACTER error.
                (decoding-error (vector octet) :utf-8 seq i
                                nil 'end-of-input-in-character)
                (return (values nchars i)))
               (t
                (setq nchars (1+ nchars)
                      i next-i)
                (when (and (plusp max) (= nchars max))
                  (return (values nchars i))))))
           finally (progn
                     (assert (= i end))
                     (return (values nchars i))))))

(define-encoder :utf-8 (getter src-type setter dest-type)
  `(lambda (src start end dest d-start)
     (declare (type ,src-type src)
              (type ,dest-type dest)
              (fixnum start end d-start))
     (loop with di fixnum = d-start
           for i fixnum from start below end
           for code of-type code-point = (,getter src i) do
           (macrolet ((set-octet (offset value)
                        `(,',setter ,value dest (the fixnum (+ di ,offset)))))
             (cond
               ;; 1 octet
               ((< code #x80)
                (set-octet 0 code)
                (incf di))
               ;; 2 octets
               ((< code #x800)
                (set-octet 0 (logior #xc0 (f-ash code -6)))
                (set-octet 1 (logior #x80 (f-logand code #x3f)))
                (incf di 2))
               ;; 3 octets
               ((< code #x10000)
                (set-octet 0 (logior #xe0 (f-ash code -12)))
                (set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -6))))
                (set-octet 2 (logior #x80 (f-logand code #x3f)))
                (incf di 3))
               ;; 4 octets
               (t
                (set-octet 0 (logior #xf0 (f-logand #x07 (f-ash code -18))))
                (set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -12))))
                (set-octet 2 (logior #x80 (f-logand #x3f (f-ash code -6))))
                (set-octet 3 (logand #x3f code))
                (incf di 4))))
           ;; XXX: this return value is obviously wrong, but I'm
           ;; leaving this in until either STRING-TO-OCTETS or some
           ;; unit test catches it.
           finally (return (the fixnum (- d-start di))))))

(define-decoder :utf-8 (getter src-type setter dest-type)
  `(lambda (src start end dest d-start)
     (declare (type ,src-type src)
              (type ,dest-type dest)
              (fixnum start end d-start))
     (let ((u2 0) (u3 0) (u4 0))
       (declare (type ub8 u2 u3 u4))
       (loop for di fixnum from d-start
             for i fixnum from start below end
             for u1 of-type ub8 = (,getter src i) do
             ;; Note: CONSUME-OCTET doesn't check if I is being
             ;; incremented past END.  We're assuming that END has
             ;; been calculated with the CODE-POINT-POINTER above that
             ;; checks this.
             (macrolet
                 ((consume-octet ()
                    `(,',getter src (incf i)))
                  (handle-error (n)
                    `(decoding-error (vector ,@(subseq '(u1 u2 u3 u4) 0 n))
                                     :utf-8 src (- i ,n) +repl+)))
               (,setter (cond
                          ((< u1 #x80)  ; 1 octet
                           u1)
                          ((>= u1 #xc2)
                           (setq u2 (consume-octet))
                           (cond
                             ((< u1 #xe0) ; 2 octets
                              (if (< (f-logxor u2 #x80) #x40)
                                  (logior (f-ash (f-logand #x1f u1) 6)
                                          (f-logxor u2 #x80))
                                  (handle-error 2)))
                             (t
                              (setq u3 (consume-octet))
                              (cond
                                ((< u1 #xf0) ; 3 octets
                                 (if (and (< (f-logxor u2 #x80) #x40)
                                          (< (f-logxor u3 #x80) #x40)
                                          (or (>= u1 #xe1) (>= u2 #xa0)))
                                     (logior
                                      (f-ash (f-logand u1 #x0f) 12)
                                      (f-logior (f-ash (f-logand u2 #x3f) 6)
                                                (f-logand u3 #x3f)))
                                     (handle-error 3)))
                                (t      ; 4 octets
                                 (setq u4 (consume-octet))
                                 (if (and (< (f-logxor u2 #x80) #x40)
                                          (< (f-logxor u3 #x80) #x40)
                                          (< (f-logxor u4 #x80) #x40)
                                          (or (>= u1 #xf1) (>= u2 #x90)))
                                     (logior
                                      (f-logior (f-ash (f-logand u1 7) 18)
                                                (f-ash (f-logxor u2 #x80) 12))
                                      (f-logior (f-ash (f-logxor u3 #x80) 6)
                                                (f-logxor u4 #x80)))
                                     (handle-error 4))))))))
                        dest di))
             finally (return (the fixnum (- d-start di)))))))

;;;; UTF-16

;;; TODO: add a way to pass some info at compile-time telling us that,
;;; for example, the maximum code-point will always be < #x10000 in
;;; which case we could simply return (* 2 (- end start)).
(defmacro utf16-octet-counter (getter type)
  `(lambda (seq start end max)
     (declare (type ,type seq) (fixnum start end max))
     (loop with noctets fixnum = 0
           for i fixnum from start below end
           for code of-type code-point = (,getter seq i)
           do (let ((new (the fixnum (+ (if (< code #x10000) 2 4) noctets))))
                (if (and (plusp max) (> new max))
                    (loop-finish)
                    (setq noctets new)))
           finally (return (values noctets i)))))

(defmacro utf-16-combine-surrogate-pairs (u1 u2)
  `(the (unsigned-byte 21)<commit_msg>Fix missing branch in UTF-8 decoder.<commit_after>;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-unicode.lisp --- Unicode encodings.
;;;
;;; Copyright (C) 2007, <NAME>  <<EMAIL>>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.

;;; This implementation is largely based on OpenMCL's l1-unicode.lisp
;;;   Copyright (C) 2006 Clozure Associates and contributors.

(in-package #:babel-encodings)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +repl+ #xfffd "Unicode replacement character code point.")
  (defconstant +byte-order-mark-code+ #xfeff)
  (defconstant +swapped-byte-order-mark-code+ #xfffe)
  (defconstant +swapped-byte-order-mark-code-32+ #xfffe0000))

;;; Some convenience macros adding FIXNUM declarations.
(defmacro f-ash (integer count) `(the fixnum (ash ,integer ,count)))
(defmacro f-logior (&rest integers) `(the fixnum (logior ,@integers)))
(defmacro f-logand (&rest integers) `(the fixnum (logand ,@integers)))
(defmacro f-logxor (&rest integers) `(the fixnum (logxor ,@integers)))

;;;; UTF-8

(define-character-encoding :utf-8
    "An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 to 4 bytes."
  :max-units-per-char 4
  :literal-char-code-limit #x80
  :bom-encoding #(#xef #xbb #xbf)
  :default-replacement #xfffd)

(define-octet-counter :utf-8 (getter type)
  `(lambda (seq start end max)
     (declare (type ,type seq) (fixnum start end max))
     (loop with noctets fixnum = 0
           for i fixnum from start below end
           for code of-type code-point = (,getter seq i) do
           (let ((new (+ (cond ((< code #x80) 1)
                               ((< code #x800) 2)
                               ((< code #x10000) 3)
                               (t 4))
                         noctets)))
             (if (and (plusp max) (> new max))
                 (loop-finish)
                 (setq noctets new)))
           finally (return (values noctets i)))))

(define-code-point-counter :utf-8 (getter type)
  `(lambda (seq start end max)
     (declare (type ,type seq) (fixnum start end max))
     (loop with nchars fixnum = 0
           with i fixnum = start
           while (< i end) do
           ;; wrote this code with LET instead of FOR because CLISP's
           ;; LOOP doesn't like WHILE clauses before FOR clauses.
           (let* ((octet (,getter seq i))
                  (next-i (+ i (cond ((< octet #x80) 1)
                                     ((< octet #xe0) 2)
                                     ((< octet #xf0) 3)
                                     (t 4)))))
             (declare (type ub8 octet) (fixnum next-i))
             (cond
               ((> next-i end)
                ;; If this error is suppressed, we return the length
                ;; calculated so far and the decoder won't see an
                ;; END-OF-INPUT-IN-CHARACTER error.
                (decoding-error (vector octet) :utf-8 seq i
                                nil 'end-of-input-in-character)
                (return (values nchars i)))
               (t
                (setq nchars (1+ nchars)
                      i next-i)
                (when (and (plusp max) (= nchars max))
                  (return (values nchars i))))))
           finally (progn
                     (assert (= i end))
                     (return (values nchars i))))))

(define-encoder :utf-8 (getter src-type setter dest-type)
  `(lambda (src start end dest d-start)
     (declare (type ,src-type src)
              (type ,dest-type dest)
              (fixnum start end d-start))
     (loop with di fixnum = d-start
           for i fixnum from start below end
           for code of-type code-point = (,getter src i) do
           (macrolet ((set-octet (offset value)
                        `(,',setter ,value dest (the fixnum (+ di ,offset)))))
             (cond
               ;; 1 octet
               ((< code #x80)
                (set-octet 0 code)
                (incf di))
               ;; 2 octets
               ((< code #x800)
                (set-octet 0 (logior #xc0 (f-ash code -6)))
                (set-octet 1 (logior #x80 (f-logand code #x3f)))
                (incf di 2))
               ;; 3 octets
               ((< code #x10000)
                (set-octet 0 (logior #xe0 (f-ash code -12)))
                (set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -6))))
                (set-octet 2 (logior #x80 (f-logand code #x3f)))
                (incf di 3))
               ;; 4 octets
               (t
                (set-octet 0 (logior #xf0 (f-logand #x07 (f-ash code -18))))
                (set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -12))))
                (set-octet 2 (logior #x80 (f-logand #x3f (f-ash code -6))))
                (set-octet 3 (logand #x3f code))
                (incf di 4))))
           ;; XXX: this return value is obviously wrong, but I'm
           ;; leaving this in until either STRING-TO-OCTETS or some
           ;; unit test catches it.
           finally (return (the fixnum (- d-start di))))))

(define-decoder :utf-8 (getter src-type setter dest-type)
  `(lambda (src start end dest d-start)
     (declare (type ,src-type src)
              (type ,dest-type dest)
              (fixnum start end d-start))
     (let ((u2 0) (u3 0) (u4 0))
       (declare (type ub8 u2 u3 u4))
       (loop for di fixnum from d-start
             for i fixnum from start below end
             for u1 of-type ub8 = (,getter src i) do
             ;; Note: CONSUME-OCTET doesn't check if I is being
             ;; incremented past END.  We're assuming that END has
             ;; been calculated with the CODE-POINT-POINTER above that
             ;; checks this.
             (macrolet
                 ((consume-octet ()
                    `(,',getter src (incf i)))
                  (handle-error (n)
                    `(decoding-error (vector ,@(subseq '(u1 u2 u3 u4) 0 n))
                                     :utf-8 src (- i ,n) +repl+)))
               (,setter (cond
                          ((< u1 #x80)  ; 1 octet
                           u1)
                          ((>= u1 #xc2)
                           (setq u2 (consume-octet))
                           (cond
                             ((< u1 #xe0) ; 2 octets
                              (if (< (f-logxor u2 #x80) #x40)
                                  (logior (f-ash (f-logand #x1f u1) 6)
                                          (f-logxor u2 #x80))
                                  (handle-error 2)))
                             (t
                              (setq u3 (consume-octet))
                              (cond
                                ((< u1 #xf0) ; 3 octets
                                 (if (and (< (f-logxor u2 #x80) #x40)
                                          (< (f-logxor u3 #x80) #x40)
                                          (or (>= u1 #xe1) (>= u2 #xa0)))
                                     (logior
                                      (f-ash (f-logand u1 #x0f) 12)
                                      (f-logior (f-ash (f-logand u2 #x3f) 6)
                                                (f-logand u3 #x3f)))
                                     (handle-error 3)))
                                (t      ; 4 octets
                                 (setq u4 (consume-octet))
                                 (if (and (< (f-logxor u2 #x80) #x40)
                                          (< (f-logxor u3 #x80) #x40)
                                          (< (f-logxor u4 #x80) #x40)
                                          (or (>= u1 #xf1) (>= u2 #x90)))
                                     (logior
                                      (f-logior (f-ash (f-logand u1 7) 18)
                                                (f-ash (f-logxor u2 #x80) 12))
                                      (f-logior (f-ash (f-logxor u3 #x80) 6)
                                                (f-logxor u4 #x80)))
                                     (handle-error 4)))))))
                          (t (handle-error 1)))
                        dest di))
             finally (return (the fixnum (- d-start di)))))))

;;;; UTF-16

;;; TODO: add a way to pass some info at compile-time telling us that,
;;; for example, the maximum code-point will always be < #x10000 in
;;; which case we could simply return (* 2 (- end start)).
(defmacro utf16-octet-counter (getter type)
  `(lambda (seq start end max)
     (declare (type ,type seq) (fixnum start end max))
     (loop with noctets fixnum = 0
           for i fixnum from start below end
           for code of-type code-point = (,getter seq i)
           do (let ((new (the fixnum (+ (if (< code #x10000) 2 4) noctets))))
                (if (and (plusp max) (> new max))
                    (loop-finish)
                    (setq noctets new)))
           finally (return (values noctets i)))))

(defmacro utf-16-combine-surrogate-pairs (u1 u2)
  `(the (unsigned-byte 21)
{'fraction_non_alphanumeric': 0.11704018165662948, 'fraction_numerical': 0.024385427979069996, 'mean_word_length': 1.4014935988620199, 'pattern_counts': {'":': 0, '<': 51, '<?xml version=': 0, '>': 25, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 96, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4852477', 'n_tokens_mistral': 6324, 'n_tokens_neox': 5735, 'n_words': 2039}