Author: yamakenz
Date: Tue Jul 10 03:12:56 2007
New Revision: 4680
Modified:
trunk/doc/COMPATIBILITY
trunk/scm/generic.scm
trunk/scm/latin.scm
trunk/scm/util.scm
trunk/test/test-util.scm
trunk/uim/uim-util.c
Log:
* uim/uim-util.c
- (find_tail): Removed
- (uim_init_util_subrs): Remove find-tail definition
* scm/util.scm
- (nthcdr): New procedure
* scm/util.scm
- Enable SRFI-1
- (list-tabulate, make-list, iota, last, append!, concatenate,
concatenate!, zip, last-pair, append-map, append-reverse, find,
any, every, fold, unfold, filter, filter-map, remove, delete,
alist-delete): Removed and replaced with SigScheme's SRFI-1
implementation
* scm/generic.scm
- (ascii-rule): Follow the specification change of iota
* scm/latin.scm
- (ascii-rule): Ditto
* test/test-util.scm
- Fix misunderstood iota specification
- Update the "passed revision" comment
* doc/COMPATIBILITY
- Add new entry "SRFI-1 procedures replacement"
Modified: trunk/doc/COMPATIBILITY
==============================================================================
--- trunk/doc/COMPATIBILITY (original)
+++ trunk/doc/COMPATIBILITY Tue Jul 10 03:12:56 2007
@@ -57,6 +57,23 @@
The changes are described below in most recently updated order.
------------------------------------------------------------------------------
+Summary: SRFI-1 procedures replacement
+Affects: uim developers, IM developers
+Updates: Scheme API
+Version: 1.5.0
+Revision: ac4680
+Date: 2007-07-10
+Modifier: YamaKen
+Related:
+URL:
+Changes:
+ (changed) iota
+Description:
+ Various SRFI-1 procedures implemented in util.scm have been replaced
+ with the SRFI-1 feature provided by SigScheme 0.8. And the
+ misunderstood second arg meaning of 'iota' has been fixed to the
+ standard one.
+------------------------------------------------------------------------------
Summary: Stricter argument precondition requirements
Affects: IM developers, Bridge developers
Updates: C API
Modified: trunk/scm/generic.scm
==============================================================================
--- trunk/scm/generic.scm (original)
+++ trunk/scm/generic.scm Tue Jul 10 03:12:56 2007
@@ -55,7 +55,7 @@
(list (list entry) entry))
list
charcode->string)
- (iota 127 32)))
+ (iota 95 32)))
(define generic-prepare-activation
(lambda (gc)
Modified: trunk/scm/latin.scm
==============================================================================
--- trunk/scm/latin.scm (original)
+++ trunk/scm/latin.scm Tue Jul 10 03:12:56 2007
@@ -1538,7 +1538,7 @@
(list (list entry) entry))
list
charcode->string)
- (iota 127 32)))
+ (iota 95 32)))
;; widgets and actions
Modified: trunk/scm/util.scm
==============================================================================
--- trunk/scm/util.scm (original)
+++ trunk/scm/util.scm Tue Jul 10 03:12:56 2007
@@ -28,6 +28,7 @@
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.
+(use srfi-1)
(use srfi-6)
(use srfi-34)
@@ -350,207 +351,6 @@
(define feature?
(lambda (sym)
(provided? (symbol->string sym))))
-
-;;
-;; SRFI procedures (don't expect 100% compatibility)
-;;
-(define list-tabulate
- (lambda (n init-proc)
- (if (< n 0)
- (error "bad length for list-tabulate")
- (let self ((i (- n 1))
- (res ()))
- (if (< i 0)
- res
- (self (- i 1)
- (cons (init-proc i) res)))))))
-
-;; This procedure does not conform to the SRFI-1 specification. The
-;; argument 'fill' is required.
-(define make-list
- (lambda (n fill)
- (list-tabulate n
- (lambda (i)
- fill))))
-
-;; This procedure does not conform to the SRFI-1 specification. The
-;; optional argument 'step' is not supported.
-(define iota
- (lambda args
- (let ((count (car args))
- (start (if (not (null? (cdr args)))
- (cadr args)
- 0)))
- (list-tabulate (- count start)
- (lambda (i)
- (+ start i))))))
-
-;; TODO: write test
-(define last
- (lambda (lst)
- (car (last-pair lst))))
-
-;; only accepts 2 lists
-;; TODO: write test
-(define append! nconc)
-
-(define concatenate
- (lambda (lists)
- (apply append lists)))
-
-(define concatenate!
- (lambda (lists)
- ;;(fold-right append! () lists)
- (fold append! () (reverse lists))))
-
-(define zip
- (lambda lists
- (let ((runs-out? (apply proc-or (map null? lists))))
- (if runs-out?
- ()
- (let* ((elms (map car lists))
- (rests (map cdr lists)))
- (cons elms (apply zip rests)))))))
-
-(define last-pair
- (lambda (lst)
- (if (pair? (cdr lst))
- (last-pair (cdr lst))
- lst)))
-
-(define append-map
- (lambda args
- (concatenate! (apply map args))))
-
-(define append-reverse
- (lambda (rev-head tail)
- (fold cons tail rev-head)))
-
-(define find
- (lambda (f lst)
- (cond
- ((null? lst)
- #f)
- ((f (car lst))
- (car lst))
- (else
- (find f (cdr lst))))))
-
-;; TODO: write test
-;; replaced with faster C version
-;;(define find-tail
-;; (lambda (pred lst)
-;; (cond
-;; ((null? lst)
-;; #f)
-;; ((pred (car lst))
-;; lst)
-;; (else
-;; (find-tail pred (cdr lst))))))
-
-(define any
- (lambda args
- (let* ((pred (car args))
- (lists (cdr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- '(#t . #f)
- (let ((res (apply pred elms)))
- (cons res res))))
- #f lists))))
-
-(define every
- (lambda args
- (let* ((pred (car args))
- (lists (cdr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- '(#t . #t)
- (let ((res (apply pred elms)))
- (cons (not res) res))))
- #f lists))))
-
-(define fold
- (lambda args
- (let* ((kons (car args))
- (knil (cadr args))
- (lists (cddr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- (cons #t state)
- (cons #f (apply kons (append elms (list state))))))
- knil lists))))
-
-(define unfold
- (lambda args
- (let ((term? (nth 0 args))
- (kar (nth 1 args))
- (kdr (nth 2 args))
- (seed (nth 3 args))
- (tail-gen (if (= (length args)
- 5)
- (nth 4 args)
- (lambda (x) ()))))
- (if (term? seed)
- (tail-gen seed)
- (cons (kar seed)
- (unfold term? kar kdr (kdr seed) tail-gen))))))
-
-(define filter
- (lambda args
- (let ((pred (car args))
- (lst (cadr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- (cons #t (reverse state))
- (let ((elm (car elms)))
- (cons #f (if (pred elm)
- (cons elm state)
- state)))))
- () (list lst)))))
-
-(define filter-map
- (lambda args
- (let ((f (car args))
- (lists (cdr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- (cons #t (reverse state))
- (let ((mapped (apply f elms)))
- (cons #f (if mapped
- (cons mapped state)
- state)))))
- () lists))))
-
-(define remove
- (lambda (pred lst)
- (filter (lambda (elm)
- (not (pred elm)))
- lst)))
-
-;; TODO: write test
-(define delete
- (lambda args
- (let ((x (car args))
- (lst (cadr args))
- (val=? (if (null? (cddr args))
- equal?
- (car (cddr args)))))
- (filter (lambda (elm)
- (not (val=? elm x)))
- lst))))
-
-(define alist-delete
- (lambda args
- (let ((key (car args))
- (alist (cadr args))
- (key=? (if (null? (cddr args))
- equal?
- (car (cddr args)))))
- (remove (lambda (elm)
- (key=? (car elm)
- key))
- alist))))
;;
Modified: trunk/test/test-util.scm
==============================================================================
--- trunk/test/test-util.scm (original)
+++ trunk/test/test-util.scm Tue Jul 10 03:12:56 2007
@@ -29,7 +29,7 @@
;;; SUCH DAMAGE.
;;;;
-;; These tests are passed at revision 4674 (new repository)
+;; These tests are passed at revision 4680 (new repository)
(use test.unit)
@@ -1057,23 +1057,23 @@
(assert-error (lambda ()
(uim '(iota -1 0))))
- (assert-error (lambda ()
- (uim '(iota 0 1))))
(assert-equal '()
+ (uim '(iota 0 1)))
+ (assert-equal '(1)
(uim '(iota 1 1)))
- (assert-equal '(1 2 3 4)
+ (assert-equal '(1 2 3 4 5)
(uim '(iota 5 1)))
(assert-error (lambda ()
(uim '(iota -1 1))))
- (assert-error (lambda ()
- (uim '(iota 1 3))))
- (assert-equal '(3 4)
+ (assert-equal '(3)
+ (uim '(iota 1 3)))
+ (assert-equal '(3 4 5 6 7)
(uim '(iota 5 3)))
(assert-error (lambda ()
(uim '(iota -1 3))))
- (assert-equal '()
+ (assert-equal '(5 6 7 8 9)
(uim '(iota 5 5))))
("test zip"
Modified: trunk/uim/uim-util.c
==============================================================================
--- trunk/uim/uim-util.c (original)
+++ trunk/uim/uim-util.c Tue Jul 10 03:12:56 2007
@@ -417,21 +417,6 @@
return res;
}
-static uim_lisp
-find_tail(uim_lisp pred, uim_lisp lst)
-{
- uim_lisp form, elem;
-
- for (; !uim_scm_nullp(lst); lst = uim_scm_cdr(lst)) {
- elem = uim_scm_car(lst);
- form = uim_scm_list2(pred, uim_scm_quote(elem));
- if (UIM_SCM_NFALSEP(uim_scm_eval(form)))
- return lst;
- }
-
- return uim_scm_f();
-}
-
const char *
uim_get_language_name_from_locale(const char *locale)
{
@@ -502,5 +487,4 @@
uim_scm_init_subr_2("string-prefix?", string_prefixp);
uim_scm_init_subr_2("string-prefix-ci?", string_prefix_cip);
uim_scm_init_subr_3("iterate-lists", iterate_lists);
- uim_scm_init_subr_2("find-tail", find_tail);
}
