[uim-commit] r702 - branches/composer/scm

[yamaken at freedesktop.org]

Author: yamaken
Date: 2005-02-23 13:56:11 -0800 (Wed, 23 Feb 2005)
New Revision: 702

Modified:
   branches/composer/scm/util.scm
Log:
* These procedures will be merged into trunk once uim 0.4.6 has been
  released

* 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


Modified: branches/composer/scm/util.scm
===================================================================
--- branches/composer/scm/util.scm	2005-02-23 16:27:13 UTC (rev 701)
+++ branches/composer/scm/util.scm	2005-02-23 21:56:11 UTC (rev 702)
@@ -71,6 +71,21 @@
     (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)
@@ -223,6 +238,23 @@
 	    arg)
 	  (reverse funcs))))
 
+;; 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))))
+
 ;;
 ;; R5RS procedures (don't expect 100% compatibility)
 ;;
@@ -346,6 +378,17 @@
      (else
       (find f (cdr lst))))))
 
+;; TODO: write test
+(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))
@@ -450,6 +493,23 @@
 		     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
 ;;