Author: deton.kih
Date: Mon May 21 06:06:34 2007
New Revision: 4554
Modified:
trunk/scm/tutcode.scm
Log:
* scm/tutcode.scm: Fix bugs when --disable-compat-siod-bugs.
- (tutcode-push-key!, tutcode-rule-commit-sequences!): Add #f check.
Fix null list check.
- (tutcode-bushu-convert, tutcode-bushu-compose,
tutcode-bushu-alternative): Add #f check
- (tutcode-bushu-decompose): Add null list check
Modified: trunk/scm/tutcode.scm
==============================================================================
--- trunk/scm/tutcode.scm (original)
+++ trunk/scm/tutcode.scm Mon May 21 06:06:34 2007
@@ -250,12 +250,13 @@
;;; @param key ������ʸ����
(define (tutcode-push-key! pc key)
(let ((res (rk-push-key! (tutcode-context-rk-context pc) key)))
- (if
- (and
- (not (null? (cadr res)))
- (tutcode-context-katakana-mode? pc))
- (cadr res)
- (car res))))
+ (and res
+ (if
+ (and
+ (not (null? (cdr res)))
+ (tutcode-context-katakana-mode? pc))
+ (cadr res)
+ (car res)))))
;;; �Ѵ������֤ꥢ���롣
;;; @param pc �����ƥ����ȥꥹ��
@@ -610,10 +611,10 @@
(tutcode-bushu-compose-sub c1 c2)))
(let* ((decomposed1 (tutcode-bushu-decompose c1))
(decomposed2 (tutcode-bushu-decompose c2))
- (tc11 (car decomposed1))
- (tc12 (cadr decomposed1))
- (tc21 (car decomposed2))
- (tc22 (cadr decomposed2))
+ (tc11 (and decomposed1 (car decomposed1)))
+ (tc12 (and decomposed1 (cadr decomposed1)))
+ (tc21 (and decomposed2 (car decomposed2)))
+ (tc22 (and decomposed2 (cadr decomposed2)))
;; ��������ʸ��������������2�Ĥ������Ȥϰۤʤ�
;; ������ʸ���Ǥ��뤳�Ȥ���ǧ���롣
;; (string=?����#f�����ä��Ȥ��˥��顼�ˤʤ��Τ�equal?������)
@@ -678,26 +679,31 @@
;;; @param c2 2���ܤ�����
;;; @return ��������ʸ���������Ǥ��ʤ��ä��Ȥ���#f
(define (tutcode-bushu-compose c1 c2)
- (car (cadr (rk-lib-find-seq (list c1 c2) tutcode-bushudic))))
+ (let ((seq (rk-lib-find-seq (list c1 c2) tutcode-bushudic)))
+ (and seq
+ (car (cadr seq)))))
;;; ���������Ѵ�:����ʸ����õ�����֤���
;;; @param c �����оݤ�ʸ��
;;; @return ����ʸ��������ʸ�������Ĥ����ʤ��ä��Ȥ��ϸ���ʸ������
(define (tutcode-bushu-alternative c)
- (or
- (cadr (assoc c tutcode-bushudic-altchar))
- c))
+ (let ((alt (assoc c tutcode-bushudic-altchar)))
+ (or
+ (and alt (cadr alt))
+ c)))
;;; ���������Ѵ�:ʸ����2�Ĥ�������ʬ�롣
;;; @param c ʬ���оݤ�ʸ��
-;;; @return ʬ�ƤǤ���2�Ĥ������Υꥹ�ȡ�ʬ���Ǥ��ʤ��ä��Ȥ���()
+;;; @return ʬ�ƤǤ���2�Ĥ������Υꥹ�ȡ�ʬ���Ǥ��ʤ��ä��Ȥ���#f
(define (tutcode-bushu-decompose c)
- (car
- (caar
- (filter
- (lambda (elem)
- (string=? c (car (cadr elem))))
- tutcode-bushudic))))
+ (let ((lst
+ (filter
+ (lambda (elem)
+ (string=? c (car (cadr elem))))
+ tutcode-bushudic)))
+ (and
+ (not (null? lst))
+ (car (caar lst)))))
;;; �����������줿�Ȥ��ν����ο���ʬ�����Ԥ���
;;; @param pc �����ƥ����ȥꥹ��
@@ -963,11 +969,12 @@
(lambda (elem)
(let* ((seq (caar elem))
(kanji (cadr elem))
- (pair (cadr (rk-lib-find-seq seq tutcode-rule))))
- (if (pair? pair)
+ (curseq (rk-lib-find-seq seq tutcode-rule))
+ (pair (and curseq (cadr curseq))))
+ (if (and pair (pair? pair))
(begin
(set-car! pair (car kanji))
- (if (not (null? (cadr kanji)))
+ (if (not (null? (cdr kanji)))
(if (< (length pair) 2)
(set-cdr! pair (list (cadr kanji)))
(set-car! (cdr pair) (cadr kanji)))))
