r4487: Auto commit for Debian build
[cl-base64.git] / encode.lisp
index d079515..f3791aa 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
+;;;; $Id: encode.lisp,v 1.5 2003/01/14 11:59:44 kevin Exp $
 ;;;;
 ;;;; This file implements the Base64 transfer encoding algorithm as
 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
@@ -28,7 +28,7 @@
 ;;;;   - Renamed functions now that supporting integer conversions
 ;;;;   - URI-compatible encoding using :uri key
 ;;;;
-;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
+;;;; $Id: encode.lisp,v 1.5 2003/01/14 11:59:44 kevin Exp $
 
 (in-package #:cl-base64)
 
        x
        (the fixnum (+ x (the fixnum (- n remainder)))))))
 
-(defun string-to-base64 (string &key (uri nil) (columns 0) (stream nil))
-  "Encode a string array to base64. If columns is > 0, designates
-maximum number of columns in a line and the string will be terminated
-with a #\Newline."
-  (declare (string string)
-          (fixnum columns)
-          (optimize (speed 3)))
-  (let ((pad (if uri *uri-pad-char* *pad-char*))
-       (encode-table (if uri *uri-encode-table* *encode-table*)))
-    (declare (simple-string encode-table)
-            (character pad))
-    (let* ((string-length (length string))
-          (complete-group-count (truncate string-length 3))
-          (remainder (nth-value 1 (truncate string-length 3)))
-          (padded-length (* 4 (truncate (+ string-length 2) 3)))
-          (num-lines (if (plusp columns)
-                         (truncate (+ padded-length (1- columns)) columns)
-                         0))
-          (num-breaks (if (plusp num-lines)
-                          (1- num-lines)
-                          0))
-          (strlen (if stream
-                      0
-                      (+ padded-length num-breaks)))
-          (result (make-string strlen))
-          (col (if (plusp columns)
-                   0
-                   (1+ padded-length)))
-          (ioutput 0))
-      (declare (fixnum string-length padded-length col ioutput)
-              (simple-string result))
-      (labels ((output-char (ch)
-                (if (= col columns)
-                    (progn
-                      (if stream
-                          (write-char #\Newline stream)
-                          (progn
-                            (setf (schar result ioutput) #\Newline)
-                            (incf ioutput)))
-                      (setq col 1))
-                    (incf col))
-                (if stream
-                    (write-char ch stream)
-                    (progn
-                      (setf (schar result ioutput) ch)
-                      (incf ioutput))))
-            (output-group (svalue chars)
-              (declare (fixnum svalue chars))
-              (output-char
-               (schar encode-table
-                      (the fixnum
-                        (logand #x3f
-                                (the fixnum (ash svalue -18))))))
-              (output-char
-               (schar encode-table
-                      (the fixnum
-                        (logand #x3f
-                                (the fixnum (ash svalue -12))))))
-              (if (> chars 2)
-                  (output-char
-                   (schar encode-table
-                          (the fixnum
-                            (logand #x3f
-                                    (the fixnum (ash svalue -6))))))
-                (output-char pad))
-              (if (> chars 3)
-                  (output-char
-                   (schar encode-table
-                          (the fixnum
-                            (logand #x3f svalue))))
-                (output-char pad))))
-       (do ((igroup 0 (1+ igroup))
-            (isource 0 (+ isource 3)))
-           ((= igroup complete-group-count)
-            (cond
-              ((= remainder 2)
-               (output-group
-                (the fixnum
-                  (+
-                   (the fixnum
-                     (ash (char-code (the character
-                                       (char string isource))) 16))
-                   (the fixnum
-                     (ash (char-code (the character
-                                       (char string (1+ isource)))) 8))))
-                3))
-              ((= remainder 1)
-               (output-group
-                (the fixnum
-                  (ash (char-code (the character (char string isource))) 16))
-                2)))
-            result)
-         (declare (fixnum igroup isource))
-         (output-group 
-          (the fixnum
-            (+
-             (the fixnum
-               (ash (char-code (the character
-                                 (char string isource))) 16))
-             (the fixnum
-               (ash (char-code (the character (char string (1+ isource)))) 8))
-             (the fixnum
-               (char-code (the character (char string (+ 2 isource)))))))
-          4))))))
-
 (defmacro def-*-to-base64-* (input-type output-type)
   `(defun ,(intern (concatenate 'string (symbol-name input-type)
-                               (symbol-name :-to-base-64-)
+                               (symbol-name :-to-base64-)
                                (symbol-name output-type)))
        (input
        ,@(when (eq output-type :stream)
-               'output)
+               '(output))
        &key (uri nil) (columns 0))
      "Encode a string array to base64. If columns is > 0, designates
 maximum number of columns in a line and the string will be terminated
 with a #\Newline."
-     (declare (,@(case input-type
-                      (:string
-                       '((string input)))
-                      (:usb8-array)
-                      '((type (array fixnum (*))) input))
-                (fixnum columns)
-                (optimize (speed 3))))
+     (declare ,@(case input-type
+                     (:string
+                      '((string input)))
+                     (:usb8-array
+                      '((type (array (unsigned-byte 8) (*)) input))))
+             (fixnum columns)
+             (optimize (speed 3)))
      (let ((pad (if uri *uri-pad-char* *pad-char*))
           (encode-table (if uri *uri-encode-table* *encode-table*)))
        (declare (simple-string encode-table)
@@ -174,126 +69,141 @@ with a #\Newline."
              (complete-group-count (truncate string-length 3))
              (remainder (nth-value 1 (truncate string-length 3)))
              (padded-length (* 4 (truncate (+ string-length 2) 3)))
-             (num-lines (if (plusp columns)
-                            (truncate (+ padded-length (1- columns)) columns)
-                            0))
-             (num-breaks (if (plusp num-lines)
-                             (1- num-lines)
-                             0))
-          (strlen (if stream
+             ,@(when (eq output-type :string)
+                     '((num-lines (if (plusp columns)
+                                      (truncate (+ padded-length (1- columns)) columns)
+                                      0))
+                       (num-breaks (if (plusp num-lines)
+                                       (1- num-lines)
+                                       0))
+                       (strlen (+ padded-length num-breaks))
+                       (result (make-string strlen))
+                       (ioutput 0)))
+             (col (if (plusp columns)
                       0
-                      (+ padded-length num-breaks)))
-          (result (make-string strlen))
-          (col (if (plusp columns)
-                   0
-                   (1+ padded-length)))
-          (ioutput 0))
-      (declare (fixnum string-length padded-length col ioutput)
-              (simple-string result))
-      (macrolet ((output-char (ch)
-                  (if (= col columns)
-                      (progn
-                        (if stream
-                            (write-char #\Newline stream)
-                            (progn
-                              (setf (schar result ioutput) #\Newline)
-                              (incf ioutput)))
-                        (setq col 1))
-                      (incf col))
-                  ,@(case output-type
-                          (:stream
-                           '((write-char ch stream))
-                           (:string
-                            '((setf (schar result ioutput) ch)
-                              (incf ioutput)))))))
-       (labels ((output-group (svalue chars)
-                  (declare (fixnum svalue chars))
-                  (output-char
-                   (schar encode-table
-                          (the fixnum
-                            (logand #x3f
-                                    (the fixnum (ash svalue -18))))))
-                  (output-char
-                   (schar encode-table
-                          (the fixnum
-                            (logand #x3f
-                                    (the fixnum (ash svalue -12))))))
-                  (if (> chars 2)
-                      (output-char
-                       (schar encode-table
-                          (the fixnum
-                            (logand #x3f
-                                    (the fixnum (ash svalue -6))))))
-                      (output-char pad))
+                      (the fixnum (1+ padded-length)))))
+        (declare (fixnum string-length padded-length col
+                         ,@(when (eq output-type :string)
+                                 '(ioutput)))
+                 ,@(when (eq output-type :string)
+                         '((simple-string result))))
+        (labels ((output-char (ch)
+                   (if (= col columns)
+                       (progn
+                         ,@(case output-type
+                                 (:stream
+                                  '((write-char #\Newline output)))
+                                (:string
+                                 '((setf (schar result ioutput) #\Newline)
+                                   (incf ioutput))))
+                         (setq col 1))
+                    (incf col))
+                ,@(case output-type
+                        (:stream
+                         '((write-char ch output)))
+                        (:string
+                         '((setf (schar result ioutput) ch)
+                           (incf ioutput)))))
+              (output-group (svalue chars)
+                (declare (fixnum svalue chars))
+                (output-char
+                 (schar encode-table
+                        (the fixnum
+                          (logand #x3f
+                                  (the fixnum (ash svalue -18))))))
+                (output-char
+                 (schar encode-table
+                        (the fixnum
+                          (logand #x3f
+                                       (the fixnum (ash svalue -12))))))
+                (if (> chars 2)
+                    (output-char
+                     (schar encode-table
+                            (the fixnum
+                              (logand #x3f
+                                      (the fixnum (ash svalue -6))))))
+                    (output-char pad))
                   (if (> chars 3)
                       (output-char
                        (schar encode-table
                               (the fixnum
                                 (logand #x3f svalue))))
-                (output-char pad))))
-         (do ((igroup 0 (1+ igroup))
-              (isource 0 (+ isource 3)))
-             ((= igroup complete-group-count)
-              (cond
-                ((= remainder 2)
-                 (output-group
-                  (the fixnum
+                      (output-char pad))))
+       (do ((igroup 0 (the fixnum (1+ igroup)))
+            (isource 0 (the fixnum (+ isource 3))))
+           ((= igroup complete-group-count)
+            (cond
+              ((= remainder 2)
+               (output-group
+                (the fixnum
                     (+
-                   (the fixnum
-                     (ash
-                      ,(case input-type
-                             (:string
-                              '(char-code (the character (char input isource))))
-                             (:usb8-array
-                              '(the fixnum (aref input isource))))
-                      16))
-                   (the fixnum
-                     (ash
-                      ,(case input-type
-                             (:string
-                              '(char-code (the character (char input (1+ isource)))))
-                             (:usb8-array
-                              '(the fixnum (aref input (1+ isource)))))
-                      8))))
-                  3))
-                ((= remainder 1)
-                 (output-group
-                  (the fixnum
-                    ,(case input-type
-                           (:string
-                            '(char-code (the character (char input isource))))
-                           (:usb8-array
-                            '(the fixnum (aref input isource)))))
-                  2)))
-              result)
-           (declare (fixnum igroup isource))
-           (output-group 
-            (the fixnum
-              (+
-               (the fixnum
-                 (ash
-                  ,(case input-type
-                         (:string
-                          '(char-code (the character (char input isource))))
-                         (:usb8-array
-                          '(the fixnum (aref input isource))))
-                  16))
-               (the fixnum
-                 (ash
+                     (the fixnum
+                       (ash
+                        ,(case input-type
+                               (:string
+                                '(char-code (the character (char input isource))))
+                               (:usb8-array
+                                '(the fixnum (aref input isource))))
+                        16))
+                     (the fixnum
+                       (ash
+                        ,(case input-type
+                               (:string
+                                '(char-code (the character (char input
+                                                                 (the fixnum (1+ isource))))))
+                               (:usb8-array
+                                '(the fixnum (aref input (the fixnum
+                                                           (1+ isource))))))
+                        8))))
+                3))
+              ((= remainder 1)
+               (output-group
+                (the fixnum
+                  (ash
+                   ,(case input-type
+                          (:string
+                           '(char-code (the character (char input isource))))
+                          (:usb8-array
+                           '(the fixnum (aref input isource))))
+                   16))
+                2)))
+            ,(case output-type
+                   (:string
+                    'result)
+                   (:stream
+                    'output)))
+         (declare (fixnum igroup isource))
+         (output-group 
+          (the fixnum
+            (+
+             (the fixnum
+               (ash
+                (the fixnum
+                ,(case input-type
+                       (:string
+                        '(char-code (the character (char input isource))))
+                       (:usb8-array
+                        '(aref input isource))))
+                16))
+             (the fixnum
+               (ash
+                (the fixnum
                   ,(case input-type
                          (:string
-                          '(char-code (the character (char input (1+ isource)))))
-                         (:usb8-array
-                          '(the fixnum (aref input (1+ isource)))))
-                  8))
-               (the fixnum
-                 ,(case input-type
-                        (:string
-                         '(char-code (the character (char input (+ 2 isource)))))
-                        (:usb8-array
-                         '(the fixnum (aref input (+ 2 isource)))))
-                 )))
-            4))))))))
+                          '(char-code (the character (char input
+                                                           (the fixnum (1+ isource))))))
+                       (:usb8-array
+                        '(aref input (1+ isource)))))
+                8))
+             (the fixnum
+               ,(case input-type
+                      (:string
+                       '(char-code (the character (char input
+                                                        (the fixnum (+ 2 isource))))))
+                      (:usb8-array
+                       '(aref input (+ 2 isource))))
+               )))
+          4)))))))
 
 (def-*-to-base64-* :string :string)
 (def-*-to-base64-* :string :stream)
@@ -383,9 +293,10 @@ with a #\Newline."
           (last-nonpad-char (1- nonpad-chars))
           (str (make-string strlen)))
       (declare (fixnum padded-length last-nonpad-char))
-      (do* ((strpos 0 (1+ strpos))
+      (do* ((strpos 0 (the fixnum (1+ strpos)))
            (int (ash input (/ padding-bits 3)) (ash int -6))
-           (6bit-value (logand int #x3f) (logand int #x3f)))
+           (6bit-value (the fixnum (logand int #x3f))
+                       (the fixnum (logand int #x3f))))
           ((= strpos nonpad-chars)
            (let ((col 0))
              (declare (fixnum col))