[uim-commit] r952 - in trunk: scm test uim
yamaken at freedesktop.org
yamaken at freedesktop.org
Sat Jul 9 03:30:04 EST 2005
Author: yamaken
Date: 2005-07-08 10:29:47 -0700 (Fri, 08 Jul 2005)
New Revision: 952
Modified:
trunk/scm/util.scm
trunk/test/test-slib.scm
trunk/test/test-uim-util.scm
trunk/test/test-util.scm
trunk/uim/slib.c
trunk/uim/uim-util.c
Log:
* test/test-slib.scm
* test/test-uim-util.scm
* test/test-util.scm
* scm/util.scm
* uim/uim-util.c
* uim/slib.c
- Merge utility functions from the composer branch into trunk as
follows
svn merge -r701:951 svn+ssh://freedesktop.org/srv/uim.freedesktop.org/svn/branches/composer/scm/util.scm scm/util.scm
svn merge -r701:951 svn+ssh://freedesktop.org/srv/uim.freedesktop.org/svn/branches/composer/uim/ uim/
svn merge -r701:951 svn+ssh://freedesktop.org/srv/uim.freedesktop.org/svn/branches/composer/test/test-util.scm test/test-util.scm
svn merge -r701:951 svn+ssh://freedesktop.org/srv/uim.freedesktop.org/svn/branches/composer/test/test-uim-util.scm test/test-uim-util.scm
----------------
r702 | yamaken | 2005-02-24 06:56:11 +0900 (Thu, 24 Feb 2005)
* scm/util.scm
- (char-vowel?, char-consonant?, safe-car, safe-cdr, assq-cdr): New
procedure
- (find-tail, bitwise-not, bitwise-and, bitwise-or, bitwise-xor):
New SRFI procedures
----------------
r703 | yamaken | 2005-02-24 07:39:13 +0900 (Thu, 24 Feb 2005)
* scm/util.scm
- Reorder procedure definitions to fix invalid forward reference to
'map' in char-vowel?. No actual code modification is applied
----------------
r775 | yamaken | 2005-03-09 04:30:51 +0900 (Wed, 09 Mar 2005)
* scm/util.scm
- (zero?, positive?, negative?): New R5RS procedure
- (clamp): New procedure
* test/test-util.scm
- (test clamp, test zero?, test positive?, test negative?): New test
----------------
r797 | yamaken | 2005-03-19 21:59:07 +0900 (Sat, 19 Mar 2005)
* uim/uim-util.c
- (string_prefixp_internal, string_prefixp, string_prefix_cip): New
function
- (uim_init_util_subrs): Add initialization of string-prefix? and
string-prefix-ci?
* test/test-uim-util.scm
- (test string-prefix?, test string-prefix-ci?): New test
----------------
r815 | yamaken | 2005-04-03 22:10:04 +0900 (Sun, 03 Apr 2005)
* This commit makes evmap rule tree initialization 1.9 times faster
* scm/util.scm
- (iterate-lists): Remove and replace with faster C version
* uim/uim-util.c
- (shift_elems, iterate_lists): New static function
- (uim_init_util_subrs): Add initialization of iterate-lists
* test/test-uim-util.scm
- (test iterate-lists): Moved from test-util.scm
* test/test-util.scm
- (test iterate-lists): Move to test-uim-util.scm
- (testcase util misc): Fix an broken form
----------------
r816 | yamaken | 2005-04-04 10:49:03 +0900 (Mon, 04 Apr 2005)
* This commit makes evmap rule tree initialization 5.5 times faster
than r815. Current startup time is about 0.8 sec on my machine. The
time will be reduced more in accordance with architectural change
for press/release handlings
* scm/util.scm
- (compose): Optimize
- (last, append!, concatenate, concatenate!): New SRFI-1 procedure
- (append-map): Optimize with concatenate!
- (find-tail): Removed to be replaced with the faster C implemantation
* uim/uim-util.c
- (iterate_lists): Simplify
- (find_tail): New static function
- (uim_init_util_subrs): Add initialization of find-tail
* uim/slib.c
- (last) Rename to last_pair() to conform to SRFI-1
- (last_pair): Renamed from last()
- (nconc): Follow the renaming
- (init_subrs): Rename Scheme procedure name 'last' with 'last-pair'
to conform to SRFI-1
* composer/test/test-uim-util.scm
* composer/test/test-util.scm
- Update comment
----------------
r820 | yamaken | 2005-04-07 14:04:52 +0900 (Thu, 07 Apr 2005)
* scm/util.scm
- (define-record): Simplify and Optimize
----------------
r950 | yamaken | 2005-07-08 21:44:54 +0900 (Fri, 08 Jul 2005)
* scm/util.scm
- (method-delegator-new, char?): New procedure
- (do-nothing): Moved from load-action.scm
Modified: trunk/scm/util.scm
===================================================================
--- trunk/scm/util.scm 2005-07-08 16:01:57 UTC (rev 951)
+++ trunk/scm/util.scm 2005-07-08 17:29:47 UTC (rev 952)
@@ -31,71 +31,6 @@
;; Current uim implementation treats char as integer
-(define char-control?
- (lambda (c)
- (and (integer? c)
- (or (<= c 31)
- (= c 127)))))
-
-(define char-upper-case?
- (lambda (c)
- (and (integer? c)
- (>= c 65)
- (<= c 90))))
-
-(define char-lower-case?
- (lambda (c)
- (and (integer? c)
- (>= c 97)
- (<= c 122))))
-
-(define char-alphabetic?
- (lambda (c)
- (or (char-upper-case? c)
- (char-lower-case? c))))
-
-(define char-numeric?
- (lambda (c)
- (and (integer? c)
- (>= c 48)
- (<= c 57))))
-
-(define char-printable?
- (lambda (c)
- (and (integer? c)
- (<= c 127)
- (not (char-control? c)))))
-
-(define char-graphic?
- (lambda (c)
- (and (char-printable? c)
- (not (= c 32)))))
-
-(define numeral-char->number
- (lambda (c)
- (if (char-numeric? c)
- (- c 48)
- c)))
-
-(define char-downcase
- (lambda (c)
- (if (char-upper-case? c)
- (+ c 32)
- c)))
-
-(define char-upcase
- (lambda (c)
- (if (char-lower-case? c)
- (- c 32)
- c)))
-
-;; backward compatibility
-(define control-char? char-control?)
-(define alphabet-char? char-alphabetic?)
-(define numeral-char? char-numeric?)
-(define usual-char? char-graphic?)
-(define to-lower-char char-downcase)
-
;; TODO: write test
(define string-escape
(lambda (s)
@@ -171,21 +106,17 @@
(or (truncate-list lst n)
(error "out of range in list-head")))))
-;; local procedure. don't use in outside of util.scm
-(define iterate-lists
- (lambda (mapper state lists)
- (let ((runs-out? (apply proc-or (mapcar null? lists))))
- (if runs-out?
- (cdr (mapper state ()))
- (let* ((elms (mapcar car lists))
- (rests (mapcar cdr lists))
- (pair (mapper state elms))
- (terminate? (car pair))
- (new-state (cdr pair)))
- (if terminate?
- new-state
- (iterate-lists mapper new-state rests)))))))
+;; TODO: write test
+(define sublist
+ (lambda (lst start end)
+ (list-tail (list-head lst (+ end 1))
+ start)))
+;; TODO: write test
+(define sublist-rel
+ (lambda (lst start len)
+ (sublist lst start (+ start len))))
+
(define alist-replace
(lambda (kons alist)
(let* ((id (car kons))
@@ -215,14 +146,45 @@
;; only accepts single-arg functions
;; (define caddr (compose car cdr cdr))
(define compose
- (lambda funcs
- (fold (lambda (f g)
- (lambda (arg)
- (f (g arg))))
- (lambda (arg)
- arg)
- (reverse funcs))))
+ (lambda args
+ (let ((funcs (if (null? args)
+ (list (lambda (x) x))
+ args)))
+ (fold (lambda (f g)
+ (lambda (arg)
+ (f (g arg))))
+ (car (reverse funcs))
+ (cdr (reverse funcs))))))
+(define method-delegator-new
+ (lambda (dest-getter method)
+ (lambda args
+ (let* ((self (car args))
+ (dest (dest-getter self)))
+ (apply method (cons dest (cdr args)))))))
+
+;; TODO: write test
+(define safe-car
+ (lambda (pair)
+ (and (pair? pair)
+ (car pair))))
+
+;; TODO: write test
+(define safe-cdr
+ (lambda (pair)
+ (and (pair? pair)
+ (cdr pair))))
+
+;; TODO: write test
+(define assq-cdr
+ (lambda (key alist)
+ (safe-cdr (assq key alist))))
+
+(define clamp
+ (lambda (x bottom ceiling)
+ (max bottom
+ (min x ceiling))))
+
;;
;; R5RS procedures (don't expect 100% compatibility)
;;
@@ -239,12 +201,31 @@
(lambda (x)
(number? x)))
+;; Siod doesn't support char
+(define char?
+ (lambda (x)
+ #f))
+
(define list?
(lambda (x)
(or (null? x)
(and (pair? x)
(list? (cdr x))))))
+(define zero?
+ (lambda (x)
+ (if (integer? x)
+ (= x 0)
+ (error "non-numeric value for zero?"))))
+
+(define positive?
+ (lambda (x)
+ (> x 0)))
+
+(define negative?
+ (lambda (x)
+ (< x 0)))
+
(define number->string integer->string)
(define string->number string->integer)
(define string->symbol intern)
@@ -280,6 +261,90 @@
(nthcdr n lst))))
;;
+;; R5RS-like character procedures
+;;
+
+(define char-control?
+ (lambda (c)
+ (and (integer? c)
+ (or (<= c 31)
+ (= c 127)))))
+
+(define char-upper-case?
+ (lambda (c)
+ (and (integer? c)
+ (>= c 65)
+ (<= c 90))))
+
+(define char-lower-case?
+ (lambda (c)
+ (and (integer? c)
+ (>= c 97)
+ (<= c 122))))
+
+(define char-alphabetic?
+ (lambda (c)
+ (or (char-upper-case? c)
+ (char-lower-case? c))))
+
+(define char-numeric?
+ (lambda (c)
+ (and (integer? c)
+ (>= c 48)
+ (<= c 57))))
+
+(define char-printable?
+ (lambda (c)
+ (and (integer? c)
+ (<= c 127)
+ (not (char-control? c)))))
+
+(define char-graphic?
+ (lambda (c)
+ (and (char-printable? c)
+ (not (= c 32)))))
+
+;; TODO: write test
+(define char-vowel?
+ (let ((vowel-chars (map string->char
+ '("a" "i" "u" "e" "o"))))
+ (lambda (c)
+ (and (char-alphabetic? c)
+ (member (char-downcase c)
+ vowel-chars)))))
+
+;; TODO: write test
+(define char-consonant?
+ (lambda (c)
+ (and (char-alphabetic? c)
+ (not (char-vowel? c)))))
+
+(define numeral-char->number
+ (lambda (c)
+ (if (char-numeric? c)
+ (- c 48)
+ c)))
+
+(define char-downcase
+ (lambda (c)
+ (if (char-upper-case? c)
+ (+ c 32)
+ c)))
+
+(define char-upcase
+ (lambda (c)
+ (if (char-lower-case? c)
+ (- c 32)
+ c)))
+
+;; backward compatibility
+(define control-char? char-control?)
+(define alphabet-char? char-alphabetic?)
+(define numeral-char? char-numeric?)
+(define usual-char? char-graphic?)
+(define to-lower-char char-downcase)
+
+;;
;; SRFI procedures (don't expect 100% compatibility)
;;
@@ -288,7 +353,6 @@
;;(define take-right)
;;(define drop-right)
;;(define split-at)
-;;(define last)
(define list-tabulate
(lambda (n init-proc)
@@ -320,7 +384,25 @@
(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))))
@@ -332,7 +414,7 @@
(define append-map
(lambda args
- (apply append (apply map args))))
+ (concatenate! (apply map args))))
(define append-reverse
(lambda (rev-head tail)
@@ -348,6 +430,18 @@
(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))
@@ -452,10 +546,29 @@
key))
alist))))
+;; SRFI-60 procedures
+;; Siod's bit operation procedures take only two arguments
+;; TODO: write tests
+(define bitwise-not bit-not)
+
+(define bitwise-and
+ (lambda xs
+ (fold bit-and (bitwise-not 0) xs)))
+
+(define bitwise-or
+ (lambda xs
+ (fold bit-or 0 xs)))
+
+(define bitwise-xor
+ (lambda xs
+ (fold bit-xor 0 xs)))
+
;;
;; uim-specific utilities
;;
+(define do-nothing (lambda args #f))
+
;; TODO: write test
(define make-scm-pathname
(lambda (file)
@@ -497,33 +610,35 @@
;; extensibility (e.g. (nth 2 spec) and so on may be used)
(define define-record
(lambda (rec-sym rec-spec)
- (let ((i 0))
- (for-each (lambda (spec)
- (let* ((index i)
- (elem-sym (nth 0 spec))
- (default (nth 1 spec))
- (getter-sym (symbolconc rec-sym '- elem-sym))
- (getter (lambda (rec)
- (nth index rec)))
- (setter-sym (symbolconc rec-sym '-set- elem-sym '!))
- (setter (lambda (rec val)
- (set-car!
- (nthcdr index rec)
- val))))
- (eval (list 'define getter-sym getter)
- toplevel-env)
- (eval (list 'define setter-sym setter)
- toplevel-env)
- (set! i (+ i 1))))
- rec-spec))
+ (for-each (lambda (spec index)
+ (let* ((elem-sym (nth 0 spec))
+ (default (nth 1 spec))
+ (getter-sym (symbolconc rec-sym '- elem-sym))
+ (getter (lambda (rec)
+ (nth index rec)))
+ (setter-sym (symbolconc rec-sym '-set- elem-sym '!))
+ (setter (lambda (rec val)
+ (set-car! (nthcdr index rec)
+ val))))
+ (eval (list 'define getter-sym getter)
+ toplevel-env)
+ (eval (list 'define setter-sym setter)
+ toplevel-env)))
+ rec-spec
+ (iota (length rec-spec)))
(let ((creator-sym (symbolconc rec-sym '-new))
- (creator (lambda init-lst
- (let ((defaults (map cadr rec-spec)))
+ (creator (let ((defaults (map cadr rec-spec)))
+ (lambda init-lst
(cond
((null? init-lst)
(copy-list defaults))
- ((<= (length init-lst)
- (length defaults))
+ ;; fast path
+ ((= (length init-lst)
+ (length defaults))
+ (copy-list init-lst))
+ ;; others
+ ((< (length init-lst)
+ (length defaults))
(let* ((rest-defaults (nthcdr (length init-lst)
defaults))
(complemented-init-lst (append init-lst
Modified: trunk/test/test-slib.scm
===================================================================
--- trunk/test/test-slib.scm 2005-07-08 16:01:57 UTC (rev 951)
+++ trunk/test/test-slib.scm 2005-07-08 17:29:47 UTC (rev 952)
@@ -41,7 +41,7 @@
(c '(c))
(d 'd))
(list a b c d))))
- (assert-equal '() (uim '(let (a) a))))
+ (assert-equal '() (uim '(let ((a)) a))))
("test named-let"
(assert-equal -1 (uim '(let - ((x -)) (x 1))))
(assert-equal '(4 3 2 1 0)
Modified: trunk/test/test-uim-util.scm
===================================================================
--- trunk/test/test-uim-util.scm 2005-07-08 16:01:57 UTC (rev 951)
+++ trunk/test/test-uim-util.scm 2005-07-08 17:29:47 UTC (rev 952)
@@ -29,7 +29,7 @@
;;; SUCH DAMAGE.
;;;;
-;; This file is tested with revision 362 of new repository
+;; This file is tested with revision 816 of new repository
(use test.unit)
@@ -124,6 +124,52 @@
; (uim '(string-to-list "a日b本語c")))
)
+ ("test string-prefix?"
+ (assert-true (uim-bool '(string-prefix? "" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix? "f" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix? "fo" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix? "foo" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix? "foo_" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix? "foo_b" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix? "foo_ba" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix? "foo_bar" "foo_bar")))
+ (assert-false (uim-bool '(string-prefix? "foo_bar_" "foo_bar")))
+ (assert-false (uim-bool '(string-prefix? #f "foo_bar")))
+ (assert-false (uim-bool '(string-prefix? "foo_bar" #f)))
+ (assert-false (uim-bool '(string-prefix? "Foo" "foo_bar")))
+ (assert-false (uim-bool '(string-prefix? "oo_" "foo_bar")))
+ (assert-false (uim-bool '(string-prefix? "bar" "foo_bar")))
+
+ (assert-true (uim-bool '(string-prefix? "" "")))
+ (assert-false (uim-bool '(string-prefix? "foo" "")))
+ (assert-false (uim-bool '(string-prefix? #f "")))
+ (assert-false (uim-bool '(string-prefix? "" #f))))
+
+ ("test string-prefix-ci?"
+ (assert-true (uim-bool '(string-prefix-ci? "" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "f" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "fo" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "foo" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "foo_" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "foo_b" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "foo_ba" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "foo_bar" "foo_bar")))
+ (assert-false (uim-bool '(string-prefix-ci? "foo_bar_" "foo_bar")))
+ (assert-false (uim-bool '(string-prefix-ci? #f "foo_bar")))
+ (assert-false (uim-bool '(string-prefix-ci? "foo_bar" #f)))
+ (assert-true (uim-bool '(string-prefix-ci? "Foo" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "fOo" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "fOO" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "FOO" "foo_bar")))
+ (assert-true (uim-bool '(string-prefix-ci? "FOO_bar" "foo_bar")))
+ (assert-false (uim-bool '(string-prefix-ci? "oo_" "foo_bar")))
+ (assert-false (uim-bool '(string-prefix-ci? "bar" "foo_bar")))
+
+ (assert-true (uim-bool '(string-prefix-ci? "" "")))
+ (assert-false (uim-bool '(string-prefix-ci? "foo" "")))
+ (assert-false (uim-bool '(string-prefix-ci? #f "")))
+ (assert-false (uim-bool '(string-prefix-ci? "" #f))))
+
("test string=?"
(assert-true (uim-bool '(string=? "foo1" "foo1")))
(assert-true (uim-bool '(string=? "Foo1" "Foo1")))
@@ -222,6 +268,17 @@
(assert-equal "1000" (uim '(digit->string 1000)))
(assert-equal "2147483647" (uim '(digit->string 2147483647))))
+ ("test iterate-lists"
+ (assert-equal '(("o" . "O") ("l" . "L") ("l" . "L") ("e" . "E") ("h" . "H"))
+ (uim '(iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t state)
+ (cons #f (cons (apply cons elms)
+ state))))
+ ()
+ '(("h" "e" "l" "l" "o")
+ ("H" "E" "L" "L" "O" "!"))))))
+
;; compare string sequence
("test str-seq-equal?"
(assert-true (uim-bool '(str-seq-equal? () ())))
Modified: trunk/test/test-util.scm
===================================================================
--- trunk/test/test-util.scm 2005-07-08 16:01:57 UTC (rev 951)
+++ trunk/test/test-util.scm 2005-07-08 17:29:47 UTC (rev 952)
@@ -29,7 +29,7 @@
;;; SUCH DAMAGE.
;;;;
-;; This file is tested with revision 268 (new repository)
+;; This file is tested with revision 816 (new repository)
(use test.unit)
@@ -434,16 +434,6 @@
(uim '(list-head lst 10))))
(assert-error (lambda ()
(uim '(list-head lst -1)))))
- ("test iterate-lists"
- (assert-equal '(("o" . "O") ("l" . "L") ("l" . "L") ("e" . "E") ("h" . "H"))
- (uim '(iterate-lists (lambda (state elms)
- (if (null? elms)
- (cons #t state)
- (cons #f (cons (apply cons elms)
- state))))
- ()
- '(("h" "e" "l" "l" "o")
- ("H" "E" "L" "L" "O" "!"))))))
("test alist-replace"
(uim '(define alist ()))
@@ -569,8 +559,78 @@
(assert-equal 4
(uim '((compose car cdr reverse) test-list)))
(assert-equal 3
- (uim '((compose car cdr cdr reverse) test-list)))))
+ (uim '((compose car cdr cdr reverse) test-list))))
+ ("test clamp"
+ (assert-equal 0 (uim '(clamp -2 0 -1)))
+ (assert-equal 0 (uim '(clamp -1 0 -1)))
+ (assert-equal 0 (uim '(clamp 0 0 -1)))
+ (assert-equal 0 (uim '(clamp 1 0 -1)))
+ (assert-equal 0 (uim '(clamp 2 0 -1)))
+ (assert-equal 0 (uim '(clamp 10 0 -1)))
+ (assert-equal -2 (uim '(clamp -2 -2 0)))
+ (assert-equal -1 (uim '(clamp -1 -2 0)))
+ (assert-equal 0 (uim '(clamp 0 -2 0)))
+ (assert-equal 0 (uim '(clamp 1 -2 0)))
+ (assert-equal 0 (uim '(clamp 2 -2 0)))
+ (assert-equal 0 (uim '(clamp 10 -2 0)))
+
+ (assert-equal -1 (uim '(clamp -2 -1 0)))
+ (assert-equal -1 (uim '(clamp -1 -1 0)))
+ (assert-equal 0 (uim '(clamp 0 -1 0)))
+ (assert-equal 0 (uim '(clamp 1 -1 0)))
+ (assert-equal 0 (uim '(clamp 2 -1 0)))
+ (assert-equal 0 (uim '(clamp 10 -1 0)))
+
+ (assert-equal 0 (uim '(clamp -2 0 0)))
+ (assert-equal 0 (uim '(clamp -1 0 0)))
+ (assert-equal 0 (uim '(clamp 0 0 0)))
+ (assert-equal 0 (uim '(clamp 1 0 0)))
+ (assert-equal 0 (uim '(clamp 2 0 0)))
+ (assert-equal 0 (uim '(clamp 10 0 0)))
+
+ (assert-equal 0 (uim '(clamp -2 0 1)))
+ (assert-equal 0 (uim '(clamp -1 0 1)))
+ (assert-equal 0 (uim '(clamp 0 0 1)))
+ (assert-equal 1 (uim '(clamp 1 0 1)))
+ (assert-equal 1 (uim '(clamp 2 0 1)))
+ (assert-equal 1 (uim '(clamp 10 0 1)))
+
+ (assert-equal 0 (uim '(clamp -2 0 2)))
+ (assert-equal 0 (uim '(clamp -1 0 2)))
+ (assert-equal 0 (uim '(clamp 0 0 2)))
+ (assert-equal 1 (uim '(clamp 1 0 2)))
+ (assert-equal 2 (uim '(clamp 2 0 2)))
+ (assert-equal 2 (uim '(clamp 10 0 2)))
+
+ (assert-equal 0 (uim '(clamp -2 0 3)))
+ (assert-equal 0 (uim '(clamp -1 0 3)))
+ (assert-equal 0 (uim '(clamp 0 0 3)))
+ (assert-equal 1 (uim '(clamp 1 0 3)))
+ (assert-equal 2 (uim '(clamp 2 0 3)))
+ (assert-equal 3 (uim '(clamp 10 0 3)))
+
+ (assert-equal 1 (uim '(clamp -2 1 3)))
+ (assert-equal 1 (uim '(clamp -1 1 3)))
+ (assert-equal 1 (uim '(clamp 0 1 3)))
+ (assert-equal 1 (uim '(clamp 1 1 3)))
+ (assert-equal 2 (uim '(clamp 2 1 3)))
+ (assert-equal 3 (uim '(clamp 10 1 3)))
+
+ (assert-equal -1 (uim '(clamp -2 -1 3)))
+ (assert-equal -1 (uim '(clamp -1 -1 3)))
+ (assert-equal 0 (uim '(clamp 0 -1 3)))
+ (assert-equal 1 (uim '(clamp 1 -1 3)))
+ (assert-equal 2 (uim '(clamp 2 -1 3)))
+ (assert-equal 3 (uim '(clamp 10 -1 3)))
+
+ (assert-equal -2 (uim '(clamp -2 -5 5)))
+ (assert-equal -1 (uim '(clamp -1 -5 5)))
+ (assert-equal 0 (uim '(clamp 0 -5 5)))
+ (assert-equal 1 (uim '(clamp 1 -5 5)))
+ (assert-equal 2 (uim '(clamp 2 -5 5)))
+ (assert-equal 5 (uim '(clamp 10 -5 5)))))
+
(define-uim-test-case "testcase util R5RS procedures"
(setup
(lambda ()
@@ -643,6 +703,48 @@
(assert-true (uim-bool '(list? '(1))))
(assert-true (uim-bool '(list? '(1 "2"))))
(assert-true (uim-bool '(list? '(1 "2" 'three)))))
+ ("test zero?"
+ (assert-error (lambda () (uim-bool '(zero? #f))))
+ (assert-error (lambda () (uim-bool '(zero? "foo"))))
+ (assert-error (lambda () (uim-bool '(zero? 'foo))))
+ (assert-false (uim-bool '(zero? -2)))
+ (assert-false (uim-bool '(zero? -1)))
+ (assert-true (uim-bool '(zero? 0)))
+ (assert-false (uim-bool '(zero? 1)))
+ (assert-false (uim-bool '(zero? 2)))
+ (assert-false (uim-bool '(zero? 10)))
+ (assert-error (lambda () (uim-bool '(zero? ()))))
+ (assert-error (lambda () (uim-bool '(zero? '(1)))))
+ (assert-error (lambda () (uim-bool '(zero? '(1 "2")))))
+ (assert-error (lambda () (uim-bool '(zero? '(1 "2" 'three))))))
+ ("test positive?"
+ (assert-error (lambda () (uim-bool '(positive? #f))))
+ (assert-error (lambda () (uim-bool '(positive? "foo"))))
+ (assert-error (lambda () (uim-bool '(positive? 'foo))))
+ (assert-false (uim-bool '(positive? -2)))
+ (assert-false (uim-bool '(positive? -1)))
+ (assert-false (uim-bool '(positive? 0)))
+ (assert-true (uim-bool '(positive? 1)))
+ (assert-true (uim-bool '(positive? 2)))
+ (assert-true (uim-bool '(positive? 10)))
+ (assert-error (lambda () (uim-bool '(positive? ()))))
+ (assert-error (lambda () (uim-bool '(positive? '(1)))))
+ (assert-error (lambda () (uim-bool '(positive? '(1 "2")))))
+ (assert-error (lambda () (uim-bool '(positive? '(1 "2" 'three))))))
+ ("test negative?"
+ (assert-error (lambda () (uim-bool '(negative? #f))))
+ (assert-error (lambda () (uim-bool '(negative? "foo"))))
+ (assert-error (lambda () (uim-bool '(negative? 'foo))))
+ (assert-true (uim-bool '(negative? -2)))
+ (assert-true (uim-bool '(negative? -1)))
+ (assert-false (uim-bool '(negative? 0)))
+ (assert-false (uim-bool '(negative? 1)))
+ (assert-false (uim-bool '(negative? 2)))
+ (assert-false (uim-bool '(negative? 10)))
+ (assert-error (lambda () (uim-bool '(negative? ()))))
+ (assert-error (lambda () (uim-bool '(negative? '(1)))))
+ (assert-error (lambda () (uim-bool '(negative? '(1 "2")))))
+ (assert-error (lambda () (uim-bool '(negative? '(1 "2" 'three))))))
("test string->symbol"
(assert-equal 'foo1
(uim '(string->symbol "foo1")))
Modified: trunk/uim/slib.c
===================================================================
--- trunk/uim/slib.c 2005-07-08 16:01:57 UTC (rev 951)
+++ trunk/uim/slib.c 2005-07-08 17:29:47 UTC (rev 952)
@@ -82,6 +82,7 @@
added NESTED_REPL_C_STRING feature (Dec-31-2004) YamaKen
added heap_alloc_threshold and make configurable (Jan-07-2005) YamaKen
added support for interactive debugging (Feb-09-2005) Jun Inoue
+ renamed 'last' to 'last-pair' to conform to SRFI-1 (Apr-04-2005) YamaKen
added inteql for "=" predicate (Jun-19-2005) YamaKen
*/
@@ -1555,7 +1556,7 @@
}
static LISP
-last (LISP l)
+last_pair (LISP l)
{
LISP v1, v2;
v1 = l;
@@ -1575,7 +1576,7 @@
if NULLP
(a)
return (b);
- setcdr (last (a), b);
+ setcdr (last_pair (a), b);
return (a);
}
@@ -4960,7 +4961,7 @@
init_subr_1 ("cdr", cdr);
init_subr_2 ("set-car!", setcar);
init_subr_2 ("set-cdr!", setcdr);
- init_subr_1 ("last", last);
+ init_subr_1 ("last-pair", last_pair);
init_subr_2n ("+", plus);
init_subr_2n ("-", difference);
init_subr_2n ("*", ltimes);
Modified: trunk/uim/uim-util.c
===================================================================
--- trunk/uim/uim-util.c 2005-07-08 16:01:57 UTC (rev 951)
+++ trunk/uim/uim-util.c 2005-07-08 17:29:47 UTC (rev 952)
@@ -436,6 +436,111 @@
return res;
}
+static uim_lisp
+string_prefixp_internal(uim_lisp prefix_, uim_lisp str_,
+ int cmp(const char *, const char *, size_t))
+{
+ const char *prefix, *str;
+ size_t len;
+
+ if (!uim_scm_stringp(prefix_) || !uim_scm_stringp(str_))
+ return uim_scm_f();
+
+ prefix = uim_scm_refer_c_str(prefix_);
+ str = uim_scm_refer_c_str(str_);
+ len = strlen(prefix);
+
+ return cmp(prefix, str, len) ? uim_scm_f() : uim_scm_t();
+}
+
+static uim_lisp
+string_prefixp(uim_lisp prefix_, uim_lisp str_)
+{
+ return string_prefixp_internal(prefix_, str_, strncmp);
+}
+
+static uim_lisp
+string_prefix_cip(uim_lisp prefix_, uim_lisp str_)
+{
+ return string_prefixp_internal(prefix_, str_, strncasecmp);
+}
+
+static uim_lisp
+shift_elems(uim_lisp lists)
+{
+ uim_lisp elms, rests, list;
+
+ if (uim_scm_nullp(lists))
+ return uim_scm_f();
+
+ elms = rests = uim_scm_null_list();
+ for (; !uim_scm_nullp(lists); lists = uim_scm_cdr(lists)) {
+ list = uim_scm_car(lists);
+ if (uim_scm_nullp(list))
+ return uim_scm_f();
+
+ elms = uim_scm_cons(uim_scm_car(list), elms);
+ rests = uim_scm_cons(uim_scm_cdr(list), rests);
+ }
+
+ return uim_scm_cons(uim_scm_reverse(elms),
+ uim_scm_reverse(rests));
+}
+
+static uim_lisp
+iterate_lists(uim_lisp mapper, uim_lisp seed, uim_lisp lists)
+{
+ uim_lisp elms, rest, rests, mapped, res, termp, pair, form;
+ uim_bool single_listp;
+
+ single_listp = (uim_scm_length(lists) == 1) ? UIM_TRUE : UIM_FALSE;
+ res = seed;
+ if (single_listp) {
+ rest = uim_scm_car(lists);
+ } else {
+ rests = lists;
+ }
+ do {
+ if (single_listp) {
+ /* fast path */
+ elms = uim_scm_list1(uim_scm_car(rest));
+ rest = uim_scm_cdr(rest);
+ } else {
+ pair = shift_elems(rests);
+ if (FALSEP(pair)) {
+ elms = rests = uim_scm_null_list();
+ } else {
+ elms = uim_scm_car(pair);
+ rests = uim_scm_cdr(pair);
+ }
+ }
+
+ form = uim_scm_list3(mapper,
+ uim_scm_quote(res),
+ uim_scm_quote(elms));
+ mapped = uim_scm_eval(form);
+ termp = uim_scm_car(mapped);
+ res = uim_scm_cdr(mapped);
+ } while (FALSEP(termp));
+
+ 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 (NFALSEP(uim_scm_eval(form)))
+ return lst;
+ }
+
+ return uim_scm_f();
+}
+
/* Following is utility functions for C world */
struct _locale_language_table {
char *locale;
@@ -520,6 +625,10 @@
uim_scm_init_subr_1("unsetenv", c_unsetenv);
uim_scm_init_subr_2("string-split", uim_split_string);
uim_scm_init_subr_1("string-to-list", eucjp_string_to_list);
+ 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);
uim_scm_init_subr_1("lang-code->lang-name-raw", lang_code_to_lang_name_raw);
uim_scm_init_subr_0("is-set-ugid?", is_setugidp);
}
More information about the uim-commit
mailing list