X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=blobdiff_plain;f=charcode.lisp;h=ac1c74d40ccd1d7e4313f5c56f61896de72e7a57;hp=1d52daee3590af807a98ea6b5f21492b7749bf5d;hb=c94c6f05729be13f1433925b0b95c363bb793284;hpb=4dd02a73cffd7edaa90aebf6641b5779af2fdbcf

diff --git a/charcode.lisp b/charcode.lisp
index 1d52dae..ac1c74d 100644
--- a/charcode.lisp
+++ b/charcode.lisp
@@ -4,13 +4,19 @@
 (defpackage :charcode
   (:use :cl #+sbcl :sb-gray #-sbcl :gray)
   (:export "MAKE-ENCODER" "MAKE-DECODER" "ENCODE-STRING" "DECODE-STRING" "SYSTEM-CHARSET"
-	   "CODING-ERROR"
+	   "NO-CODEC-ERROR" "CODING-ERROR"
 	   "MAKE-CODEC-CHARACTER-STREAM"
 	   "ASCII" "LATIN-1" "LATIN1" "UTF-8" "UTF8"))
 (in-package :charcode)
 
 ;;; General stuff
 
+(define-condition no-codec-error (error)
+  ((codec-name :initarg :codec-name))
+  (:report (lambda (c s)
+	     (with-slots (codec-name) c
+	       (format s "Could find no codec named ~A." codec-name)))))
+
 (define-condition coding-error (error)
   ((input :initarg :input)
    (position :initarg :position)
@@ -46,10 +52,12 @@
 	       synonyms)))
 
 (defun make-encoder (name)
-  (the encoder-fun (values (funcall (get name 'make-encoder)))))
+  (the encoder-fun (values (funcall (or (get name 'make-encoder)
+					(error 'no-codec-error :codec-name name))))))
 
 (defun make-decoder (name)
-  (the decoder-fun (values (funcall (get name 'make-decoder)))))
+  (the decoder-fun (values (funcall (or (get name 'make-decoder)
+					(error 'no-codec-error :codec-name name))))))
 
 (defun system-charset ()
   ;; XXX: Replace me with something perhaps more sensible.
@@ -99,7 +107,7 @@
   (with-slots (decoder back buffer read-pos) stream
     (let ((readbuf (make-array (list len) :element-type '(unsigned-byte 8))))
       (loop (unless (< (- (length buffer) read-pos) len) (return t))
-	 (let ((readlen (read-sequence readbuf back)))
+	 (let ((readlen (read-sequence readbuf back :end (- len (- (length buffer) read-pos)))))
 	   (when (= readlen 0)
 	     (return-from ccs-ensure-buffer nil))
 	   (funcall decoder readbuf buffer :end readlen))))))
@@ -108,8 +116,8 @@
   (declare (type codec-character-stream stream))
   (with-slots (read-pos buffer) stream
     (replace buffer buffer :start2 read-pos)
-	(setf (fill-pointer buffer) (- (fill-pointer buffer) read-pos)
-	      read-pos 0)))
+    (setf (fill-pointer buffer) (- (fill-pointer buffer) read-pos)
+	  read-pos 0)))
 
 (defmethod stream-read-char ((stream codec-character-stream))
   (unless (ccs-ensure-buffer stream 1)
@@ -127,8 +135,7 @@
 	  (adjust-array buffer (list (setf (fill-pointer buffer)
 					   (+ len 16)))))
 	(replace buffer buffer :start1 16 :end2 len)))
-    (setf (aref buffer read-pos) char)
-    (decf read-pos)
+    (setf (aref buffer (decf read-pos)) char)
     nil))
 
 (defun ccs-wont-hang-p (stream)
@@ -242,6 +249,8 @@
 (define-encoder (ascii)
   #'encode-ascii)
 
+(define-codec-synonyms ascii :ascii)
+
 ;;; Latin-1
 
 (defun decode-latin-1 (byteseq charseq &key (start 0) (end (length byteseq)))
@@ -279,7 +288,7 @@
 (define-encoder (latin-1)
   #'encode-latin-1)
 
-(define-codec-synonyms latin-1 latin1 iso-8859-1)
+(define-codec-synonyms latin-1 latin1 iso-8859-1 :latin-1 :latin1 :iso-8859-1)
 
 ;;; UTF-8
 
@@ -363,4 +372,4 @@
 			(setf mlen 0))))))))
       #'decode)))
 
-(define-codec-synonyms utf-8 utf8)
+(define-codec-synonyms utf-8 utf8 :utf-8 :utf8)