Dolda2000 GitWeb
/
lisp-utils.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Signal an error when a named codec could not be found.
[lisp-utils.git]
/
charcode.lisp
diff --git
a/charcode.lisp
b/charcode.lisp
index
1d52dae
..
ac1c74d
100644
(file)
--- 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"
(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
"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)
(define-condition coding-error (error)
((input :initarg :input)
(position :initarg :position)
@@
-46,10
+52,12
@@
synonyms)))
(defun make-encoder (name)
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)
(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.
(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))
(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))))))
(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)
(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)
(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)))
(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)
nil))
(defun ccs-wont-hang-p (stream)
@@
-242,6
+249,8
@@
(define-encoder (ascii)
#'encode-ascii)
(define-encoder (ascii)
#'encode-ascii)
+(define-codec-synonyms ascii :ascii)
+
;;; Latin-1
(defun decode-latin-1 (byteseq charseq &key (start 0) (end (length byteseq)))
;;; 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-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
;;; UTF-8
@@
-363,4
+372,4
@@
(setf mlen 0))))))))
#'decode)))
(setf mlen 0))))))))
#'decode)))
-(define-codec-synonyms utf-8 utf8)
+(define-codec-synonyms utf-8 utf8
:utf-8 :utf8
)