[uim-commit] r816 - in branches/composer: scm test uim
yamaken at freedesktop.org
yamaken at freedesktop.org
Sun Apr 3 18:49:18 PDT 2005
Author: yamaken
Date: 2005-04-03 18:49:03 -0700 (Sun, 03 Apr 2005)
New Revision: 816
Modified:
branches/composer/scm/evmap.scm
branches/composer/scm/ng-japanese-romaji.scm
branches/composer/scm/ng-japanese.scm
branches/composer/scm/util.scm
branches/composer/test/test-evmap.scm
branches/composer/test/test-uim-util.scm
branches/composer/test/test-util.scm
branches/composer/uim/slib.c
branches/composer/uim/uim-util.c
Log:
* 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/evmap.scm
- (event-exp-list?): New procedure to acquire better performance
than list?
- (event-exp-collector-exp, event-exp-collector-fold-elem,
event-exp-collector-fold-internal, event-exp-add-elem,
event-exp-has-elem?, event-exp-match?, evmap-tree-find-branches,
evmap-tree-insert-node!): Optimize
- (event-exp-collector-normalize-predicates!,
event-exp-implicit-macro?, event-exp-list-expand-macro,
event-exp-list-expand-macro, event-exp-seq-parse,
action-exp-seq-parse): Optimize by creating dedicated fast path
for the case most frequently occurs
- (event-exp-formal-macro?): New procedure
- (event-exp-macro?): Simplify with event-exp-formal-macro?
* 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
* scm/ng-japanese.scm
- (ja-extract-dedicated-ruleset): Optimize
* scm/ng-japanese-romaji.scm
- (ja-romaji-generate-double-consonant-ruleset): Ditto
* composer/test/test-uim-util.scm
* composer/test/test-evmap.scm
* composer/test/test-util.scm
- Update comment
Modified: branches/composer/scm/evmap.scm
===================================================================
--- branches/composer/scm/evmap.scm 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/scm/evmap.scm 2005-04-04 01:49:03 UTC (rev 816)
@@ -65,6 +65,11 @@
(require "ng-key.scm")
+(define event-exp-list?
+ (lambda (x)
+ (or (pair? x)
+ (null? x))))
+
;;
;; event expression
;;
@@ -136,11 +141,20 @@
(lambda (evc)
(let* ((pred-alist (event-exp-collector-pred-alist evc))
(predicates (event-exp-collector-predicates evc))
- (normalized (filter-map (lambda (pair)
- (let ((pred (cdr pair)))
- (and (memq pred predicates)
- pred)))
- pred-alist)))
+ (normalized (or ;; fast path
+ (and (= (length predicates)
+ 1)
+ (find-tail (lambda (pair)
+ (eq? (car predicates)
+ (cdr pair)))
+ pred-alist)
+ predicates)
+ ;; ordinary path
+ (filter-map (lambda (pair)
+ (let ((pred (cdr pair)))
+ (and (memq pred predicates)
+ pred)))
+ pred-alist))))
(event-exp-collector-set-predicates! evc normalized))))
;; returns normalized event-exp expression
@@ -149,7 +163,7 @@
(event-exp-collector-normalize-predicates! evc)
(let* ((modifier (event-exp-collector-modifier evc))
(exp-list (remove not
- (append
+ (append!
(list
(event-exp-collector-str evc)
(event-exp-collector-lkey evc)
@@ -163,34 +177,34 @@
exp-list))))
(define event-exp-collector-fold-elem
- (lambda (evc exp)
- (let ((pred-alist (event-exp-collector-pred-alist evc))
- (evc-error (lambda (msg)
- (error (string-append "invalid event-exp expression: "
- msg)))))
+ (let ((evc-error (lambda (msg)
+ (error (string-append "invalid event-exp expression: "
+ msg)))))
+ (lambda (evc exp)
(cond
((string? exp)
(if (event-exp-collector-str evc)
(evc-error "duplicated str"))
(event-exp-collector-set-str! evc exp))
((symbol? exp)
- (cond
- ((modifier-symbol? exp)
- (event-exp-collector-add-modifier! evc (symbol-value exp)))
- ((assq exp pred-alist)
- (let ((match? (assq-cdr exp pred-alist)))
- (event-exp-collector-add-predicate! evc match?)))
- ((logical-key? exp)
- (if (event-exp-collector-lkey evc)
- (evc-error "duplicated logical key"))
- (event-exp-collector-set-lkey! evc exp))
- ((physical-key? exp)
- (if (event-exp-collector-pkey evc)
- (evc-error "duplicated physical key"))
- (event-exp-collector-set-pkey! evc exp))
- (else
- (evc-error (string-append "unknown symbol '" exp)))))
- ((list? exp)
+ (let ((pred-ent (assq exp (event-exp-collector-pred-alist evc))))
+ (cond
+ (pred-ent
+ (let ((match? (cdr pred-ent)))
+ (event-exp-collector-add-predicate! evc match?)))
+ ((modifier-symbol? exp)
+ (event-exp-collector-add-modifier! evc (symbol-value exp)))
+ ((logical-key? exp)
+ (if (event-exp-collector-lkey evc)
+ (evc-error "duplicated logical key"))
+ (event-exp-collector-set-lkey! evc exp))
+ ((physical-key? exp)
+ (if (event-exp-collector-pkey evc)
+ (evc-error "duplicated physical key"))
+ (event-exp-collector-set-pkey! evc exp))
+ (else
+ (evc-error (string-append "unknown symbol '" exp))))))
+ ((pair? exp)
(evc-error "invalid nested list"))
(else
(evc-error "invalid element")))
@@ -202,7 +216,7 @@
(fold (lambda (exp evc)
(event-exp-collector-fold-elem evc exp))
evc
- (if (list? exp)
+ (if (event-exp-list? exp)
exp
(list exp))))))
@@ -213,7 +227,7 @@
(define event-exp-add-elem
(lambda (exp elem)
- (if (list? exp)
+ (if (event-exp-list? exp)
(cons elem exp)
(list elem exp))))
@@ -225,7 +239,7 @@
(define event-exp-has-elem?
(lambda (exp elem)
- (if (list? exp)
+ (if (event-exp-list? exp)
(member elem exp)
(equal? elem exp))))
@@ -273,7 +287,7 @@
(elem ev))
(else
#f)))
- (if (list? exp)
+ (if (event-exp-list? exp)
exp
(list exp)))
(or modifier-explicitly-matched?
@@ -289,26 +303,29 @@
;; abbreviation of press-release macro
(define event-exp-implicit-macro?
+ (let ((implicit-macro-body? (lambda (elem)
+ (or (string? elem)
+ (logical-key? elem)
+ (physical-key? elem)))))
+ (lambda (exp)
+ (if (pair? exp)
+ (and (not (memq 'press exp))
+ (not (memq 'release exp))
+ (not (assq (car exp) event-exp-macro-alist))
+ (find implicit-macro-body? exp))
+ (implicit-macro-body? exp)))))
+
+(define event-exp-formal-macro?
(lambda (exp)
- (let ((exp-list (if (list? exp)
- exp
- (list exp))))
- (and (not (memq 'press exp-list))
- (not (memq 'release exp-list))
- (not (assq (car exp-list) event-exp-macro-alist))
- (find (lambda (elem)
- (or (string? elem)
- (logical-key? elem)
- (physical-key? elem)))
- exp-list)))))
+ (let ((macro-sym (safe-car exp)))
+ (and macro-sym
+ (symbol? macro-sym)
+ (assq-cdr macro-sym event-exp-macro-alist)))))
(define event-exp-macro?
(lambda (exp)
- (let ((macro-sym (safe-car exp)))
- (or (and macro-sym
- (symbol? macro-sym)
- (assq-cdr macro-sym event-exp-macro-alist))
- (event-exp-implicit-macro? exp)))))
+ (or (event-exp-implicit-macro? exp)
+ (event-exp-formal-macro? exp))))
;; 'press-release' macro
;; Collects corresponding release edge of the key. Default behavior.
@@ -416,17 +433,16 @@
(let ((exp (car ev-exps))
(rest (cdr ev-exps)))
(cond
- ;; macro
- ((event-exp-macro? exp)
- (let* ((implicit-macro? (event-exp-implicit-macro? exp))
- (macro-sym (if implicit-macro?
- 'press-release
- (car exp)))
- (macro-args (if implicit-macro?
- (if (list? exp)
- exp
- (list exp))
- (cdr exp)))
+ ;; fast path for implicit press-release macro
+ ((event-exp-implicit-macro? exp)
+ (let ((expanded (car (event-exp-expand-macro-press-release exp))))
+ (event-exp-list-expand-macro
+ rest
+ (append-reverse expanded parsed))))
+ ;; ordinary macros
+ ((event-exp-formal-macro? exp)
+ (let* ((macro-sym (car exp))
+ (macro-args (cdr exp))
(macro (assq-cdr macro-sym event-exp-macro-alist)))
(append-map (lambda (expanded)
(event-exp-list-expand-macro
@@ -437,10 +453,51 @@
(else
(event-exp-list-expand-macro rest (cons exp parsed))))))))
+(define event-exp-list-expand-macro
+ (lambda (ev-exps parsed)
+ (if (null? ev-exps)
+ (list (concatenate (reverse parsed)))
+ (let ((exp (car ev-exps))
+ (rest (cdr ev-exps)))
+ (cond
+ ;; fast path for implicit press-release macro
+ ((event-exp-implicit-macro? exp)
+ (let ((expanded (car (event-exp-expand-macro-press-release exp))))
+ (event-exp-list-expand-macro
+ rest
+ (cons expanded parsed))))
+ ;; ordinary macros
+ ((event-exp-formal-macro? exp)
+ (let* ((macro-sym (car exp))
+ (macro-args (cdr exp))
+ (macro (assq-cdr macro-sym event-exp-macro-alist)))
+ (append-map (lambda (expanded)
+ (event-exp-list-expand-macro
+ rest
+ (cons expanded parsed)))
+ (macro macro-args))))
+ ;; AND expression, other simple elements
+ (else
+ (event-exp-list-expand-macro rest (cons (list exp) parsed))))))))
+
;; returns list of ev-exps
(define event-exp-seq-parse
- (let ((canonicalize (compose event-exp-collector-exp
- event-exp-collector-fold)))
+ (let* ((list-canonicalize (compose event-exp-collector-exp
+ event-exp-collector-fold))
+ (canonicalize (lambda (exp)
+ (cond
+ ;; fast path for simple press-release elements
+ ((and (pair? exp)
+ (= (length exp)
+ 2)
+ (memq (car exp)
+ '(press release))
+ (string? (cadr exp)))
+ (list (cadr exp)
+ (event-exp-predicate (car exp))))
+ ;; other expressions
+ (else
+ (list-canonicalize exp))))))
(lambda (ev-exp-seq)
(let ((expandeds (event-exp-list-expand-macro ev-exp-seq ())))
(map (lambda (expanded)
@@ -526,16 +583,18 @@
(event-exp-collector-fold-internal exp action-exp-collector-new)))
(define action-exp-seq-parse
- (lambda (act-exps)
- (let ((action-symbol? (lambda (sym)
- (and (symbol? sym)
- (string-prefix? "action_"
- (symbol->string sym))
- sym)))
- (canonicalize (compose event-exp-collector-exp
- action-exp-collector-fold)))
+ (let ((action-symbol? (lambda (sym)
+ (and (symbol? sym)
+ (string-prefix? "action_"
+ (symbol->string sym))
+ sym)))
+ (canonicalize (compose event-exp-collector-exp
+ action-exp-collector-fold)))
+ (lambda (act-exps)
(map (lambda (exp)
- (or (action-symbol? exp)
+ (or (and (string? exp)
+ exp)
+ (action-symbol? exp)
(canonicalize exp)))
act-exps))))
@@ -636,17 +695,15 @@
(ev=? (if (null? (cddr args))
event-exp-match?
(car (cddr args)))))
- (and (evmap-tree-node? tree)
- (find-tail (lambda (child)
- (let ((child-ev (evmap-tree-event child)))
- (ev=? child-ev ev)))
- (evmap-tree-branches tree))))))
+ (find-tail (lambda (child)
+ (ev=? (evmap-tree-event child) ev))
+ (evmap-tree-branches tree)))))
(define evmap-tree-insert-node!
(lambda (tree node)
- (let ((inserted (cons node (evmap-tree-branches tree))))
- (evmap-tree-set-branches! tree inserted)
- node)))
+ (evmap-tree-set-branches! tree
+ (cons node (evmap-tree-branches tree)))
+ node))
;; presumes normalized
(define evmap-tree-insert-rule!
@@ -664,6 +721,20 @@
(evmap-tree-set-action-seq! child act-exps)
(evmap-tree-insert-rule! child rest act-exps))))))
+;; simple but slower
+;;(define evmap-tree-insert-rule!
+;; (lambda (tree ev-exps act-exps)
+;; (if (null? ev-exps)
+;; (error "invalid null event expression in rule")
+;; (evmap-tree-set-action-seq!
+;; (fold (lambda (ev-exp node)
+;; (or (safe-car (evmap-tree-find-branches node ev-exp equal?))
+;; (evmap-tree-insert-node! node
+;; (evmap-tree-new ev-exp))))
+;; tree
+;; ev-exps)
+;; act-exps))))
+
;; API
;; returns evmap-tree
(define evmap-parse-ruleset
Modified: branches/composer/scm/ng-japanese-romaji.scm
===================================================================
--- branches/composer/scm/ng-japanese-romaji.scm 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/scm/ng-japanese-romaji.scm 2005-04-04 01:49:03 UTC (rev 816)
@@ -64,7 +64,7 @@
(let* ((seq (evmap-rule-event-seq rule))
(res (evmap-rule-action-seq rule))
(listified (map (lambda (elem)
- (if (list? elem)
+ (if (pair? elem)
elem
(list elem)))
res)))
Modified: branches/composer/scm/ng-japanese.scm
===================================================================
--- branches/composer/scm/ng-japanese.scm 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/scm/ng-japanese.scm 2005-04-04 01:49:03 UTC (rev 816)
@@ -143,7 +143,7 @@
(map (lambda (rule)
(let ((kana (kana-extractor (evmap-rule-action-seq rule))))
(list (evmap-rule-event-seq rule)
- (if (list? kana)
+ (if (pair? kana)
kana
(list kana)))))
ruleset)))
Modified: branches/composer/scm/util.scm
===================================================================
--- branches/composer/scm/util.scm 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/scm/util.scm 2005-04-04 01:49:03 UTC (rev 816)
@@ -135,13 +135,15 @@
;; 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))))))
;; TODO: write test
(define safe-car
@@ -326,7 +328,6 @@
;;(define take-right)
;;(define drop-right)
;;(define split-at)
-;;(define last)
(define list-tabulate
(lambda (n init-proc)
@@ -358,7 +359,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))))
@@ -370,7 +389,7 @@
(define append-map
(lambda args
- (apply append (apply map args))))
+ (concatenate! (apply map args))))
(define append-reverse
(lambda (rev-head tail)
@@ -387,15 +406,16 @@
(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))))))
+;; 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
Modified: branches/composer/test/test-evmap.scm
===================================================================
--- branches/composer/test/test-evmap.scm 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/test/test-evmap.scm 2005-04-04 01:49:03 UTC (rev 816)
@@ -29,7 +29,7 @@
;;; SUCH DAMAGE.
;;;;
-;; This file is tested with revision 707 of new repository
+;; This file is tested with revision 816 of new repository
(use test.unit)
Modified: branches/composer/test/test-uim-util.scm
===================================================================
--- branches/composer/test/test-uim-util.scm 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/test/test-uim-util.scm 2005-04-04 01:49:03 UTC (rev 816)
@@ -29,7 +29,7 @@
;;; SUCH DAMAGE.
;;;;
-;; This file is tested with revision 815 of new repository
+;; This file is tested with revision 816 of new repository
(use test.unit)
Modified: branches/composer/test/test-util.scm
===================================================================
--- branches/composer/test/test-util.scm 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/test/test-util.scm 2005-04-04 01:49:03 UTC (rev 816)
@@ -29,7 +29,7 @@
;;; SUCH DAMAGE.
;;;;
-;; This file is tested with revision 815 (new repository)
+;; This file is tested with revision 816 (new repository)
(use test.unit)
Modified: branches/composer/uim/slib.c
===================================================================
--- branches/composer/uim/slib.c 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/uim/slib.c 2005-04-04 01:49:03 UTC (rev 816)
@@ -81,6 +81,7 @@
removed non-standard _"str" syntax for i18n (Sep-30-2004) YamaKen
added NESTED_REPL_C_STRING feature (Dec-31-2004) YamaKen
added heap_alloc_threshold and make configurable (Jan-07-2005) YamaKen
+ renamed 'last' to 'last-pair' to conform to SRFI-1 (Apr-04-2005) YamaKen
*/
#include "config.h"
@@ -1429,7 +1430,7 @@
}
static LISP
-last (LISP l)
+last_pair (LISP l)
{
LISP v1, v2;
v1 = l;
@@ -1449,7 +1450,7 @@
if NULLP
(a)
return (b);
- setcdr (last (a), b);
+ setcdr (last_pair (a), b);
return (a);
}
@@ -4692,7 +4693,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: branches/composer/uim/uim-util.c
===================================================================
--- branches/composer/uim/uim-util.c 2005-04-03 13:10:04 UTC (rev 815)
+++ branches/composer/uim/uim-util.c 2005-04-04 01:49:03 UTC (rev 816)
@@ -490,12 +490,10 @@
static uim_lisp
iterate_lists(uim_lisp mapper, uim_lisp seed, uim_lisp lists)
{
- uim_lisp sym_apply, form;
- uim_lisp elms, rest, rests, mapped, res, termp, pair;
+ 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;
- sym_apply = uim_scm_make_symbol("apply");
res = seed;
if (single_listp) {
rest = uim_scm_car(lists);
@@ -517,9 +515,9 @@
}
}
- form = uim_scm_list3(sym_apply,
- mapper,
- uim_scm_quote(uim_scm_list2(res, elms)));
+ 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);
@@ -528,6 +526,21 @@
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;
@@ -615,6 +628,7 @@
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