Jun Inoue
jun.l****@gmail*****
2005年 9月 1日 (木) 18:14:28 JST
・write/ss で、SigScheme 特有の事情 (procedure, values が表示される) に よるバグと、hash table が伸長する場合の戻り値の勘違いによるバグを直しま した。 ・prime.scm などの作業中のものがいくつか混ざってます。全部 trivial な変 更。PRIME 自体はまだうまく動いてないです…全体構造を理解してないから作業 が遅い。 ↑が sscm-write-ss3.diff。↓が uim-lock.diff。 ・uim_find_context() にバグがあったので直そうとすると、ちょうど徳永さん が修正を commit されたのでやめようかと思ったんですが、違うやり方なので一 応投げてみます。ミソは sig_atomic_t より小さいオブジェクトの read/write は atomic であると仮定するというところです。[1]によれば、大抵の環境では ポインタは atomic object のようなので、これでロックが減らせると思ったん ですが、ちょっとキモいですかね… [1] "The GNU C Library" http://www.delorie.com/gnu/docs/glibc/libc_496.html -- Jun Inoue jun.l****@gmail***** -------------- next part -------------- diff -Nur ./scm/hk.scm ../.r5rs/scm/hk.scm --- ./scm/hk.scm 2005-03-11 01:26:50.000000000 -0800 +++ ../.r5rs/scm/hk.scm 2005-08-31 21:32:02.000000000 -0700 @@ -81,7 +81,7 @@ (define hk-make-match-list (lambda (left) - (mapcar + (map (lambda(l) (car (cadr l))) left))) @@ -94,7 +94,7 @@ (define hk-left-string-match (lambda (hkc) (let* ((left (hk-left-string-list hkc)) - (match-list (mapcar + (match-list (map (lambda(l) (car (cadr l))) left)) @@ -157,7 +157,7 @@ (define hk-make-str-list (lambda (str) (if str - (mapcar + (map (lambda (s) (let ((splitted (string-split s " "))) (if splitted @@ -214,7 +214,7 @@ (table-id (hk-context-table-id hkc))) (if str-list (begin - (mapcar (lambda (s) + (map (lambda (s) ; (print str) (if str (set! str (string-append str " " s)) @@ -232,7 +232,7 @@ (table-id (hk-context-table-id hkc))) (if str-list (begin - (mapcar (lambda (s) + (map (lambda (s) (if str (set! str (string-append str " " s)) (set! str s))) @@ -247,7 +247,7 @@ (table-id (hk-context-table-id hkc))) (if str-list (begin - (mapcar + (map (lambda (s) (set! str (string-append str " " s))) str-list) diff -Nur ./scm/prime.scm ../.r5rs/scm/prime.scm --- ./scm/prime.scm 2005-08-31 20:36:00.000000000 -0700 +++ ../.r5rs/scm/prime.scm 2005-09-01 01:52:29.000000000 -0700 @@ -142,24 +142,24 @@ (language (prime-context-language context)) (keymap)) (cond - ((= state 'prime-state-segment) + ((eq? state 'prime-state-segment) (set! keymap prime-keymap-segment-state)) - ((= state 'prime-state-modifying) + ((eq? state 'prime-state-modifying) (set! keymap prime-keymap-modify-state)) - ((= state 'prime-state-converting) - (if (= language 'Japanese) + ((eq? state 'prime-state-converting) + (if (eq? language 'Japanese) (set! keymap prime-keymap-conv-state) (set! keymap prime-keymap-english-conv-state))) - ((= state 'prime-state-preedit) - (if (= language 'Japanese) + ((eq? state 'prime-state-preedit) + (if (eq? language 'Japanese) (set! keymap prime-keymap-preedit-state) (set! keymap prime-keymap-english-preedit-state))) - ((= state 'prime-state-fund) - (if (= language 'Japanese) + ((eq? state 'prime-state-fund) + (if (eq? language 'Japanese) (if (prime-context-parent-context context) (set! keymap prime-keymap-child-fund-state) (set! keymap prime-keymap-fund-state)) @@ -538,7 +538,7 @@ (prime-lib-init prime-use-unixdomain?) (let ((session (prime-engine-session-start))) (prime-custom-init) - (prime-context-set-fund-line! context (cons (list) (list))) + (prime-context-set-fund-line! context (cons () ())) (prime-context-set-session! context session) (prime-context-set-lang-session-list! context @@ -567,7 +567,7 @@ (define prime-context-pop (lambda (context) (let ((parent-context (prime-context-parent-context context))) - (mapcar + (map (lambda (lang-pair) (prime-engine-session-end (cdr lang-pair))) (prime-context-lang-session-list context)) @@ -585,7 +585,7 @@ (define prime-context-history-update! (lambda (context) (let* ((state (prime-context-state context)) - (selected-index (if (= state 'prime-state-segment) + (selected-index (if (eq? state 'prime-state-segment) (prime-context-segment-nth context) (prime-context-nth context)))) (prime-context-set-history! @@ -602,7 +602,7 @@ (lambda (context) (let* ((prev-data (prime-context-history context)) (state (prime-context-state context)) - (selected-index (if (= state 'prime-state-segment) + (selected-index (if (eq? state 'prime-state-segment) (prime-context-segment-nth context) (prime-context-nth context)))) (cond @@ -686,7 +686,7 @@ (define prime-util-assoc-list (lambda (lst) - (mapcar + (map (lambda (str) (string-split str "=")) lst))) @@ -714,7 +714,7 @@ (lambda (string) (let ((integer 0) (figure 1)) - (mapcar + (map (lambda (digit-string) (if (string=? digit-string "-") (set! integer (- integer)) @@ -778,7 +778,7 @@ (let* ((result (prime-engine-send-command (list command prime-session))) (index (prime-util-string-to-integer (car result))) - (words (mapcar + (words (map (lambda (string-line) (let ((word-data (prime-util-string-split string-line "\t"))) @@ -855,7 +855,7 @@ (define prime-engine-session-language-set (lambda (language) - (let ((language-string (if (= language 'English) "English" "Japanese"))) + (let ((language-string (if (eq? language 'English) "English" "Japanese"))) (car (prime-engine-send-command (list "session_start" language-string)))))) @@ -990,7 +990,7 @@ ;; This changes the typing mode specified by mode-string. (define prime-mode-set-mode (lambda (context mode-string) - (if (= (prime-context-state context) 'prime-state-converting) + (if (eq? (prime-context-state context) 'prime-state-converting) (prime-convert-cancel context)) (prime-engine-edit-set-mode (prime-context-session context) mode-string))) @@ -1021,7 +1021,7 @@ (define prime-command-language-toggle (lambda (context key key-state) - (let ((next-language (if (= (prime-context-language context) 'English) + (let ((next-language (if (eq? (prime-context-language context) 'English) 'Japanese 'English))) (prime-mode-language-set context next-language)))) @@ -1308,8 +1308,8 @@ (define prime-command-fund-space (lambda (context key key-state) (cond - ((= (prime-context-language context) 'Japanese) - (let ((space (if (= prime-custom-japanese-space 'wide) " " " "))) + ((eq? (prime-context-language context) 'Japanese) + (let ((space (if (eq? prime-custom-japanese-space 'wide) " " " "))) (prime-commit-without-learning context space))) (t (prime-commit-without-learning context " "))))) @@ -1317,8 +1317,8 @@ (define prime-command-fund-altspace (lambda (context key key-state) (cond - ((= (prime-context-language context) 'Japanese) - (let ((space (if (= prime-custom-japanese-space 'wide) " " " "))) + ((eq? (prime-context-language context) 'Japanese) + (let ((space (if (eq? prime-custom-japanese-space 'wide) " " " "))) (prime-commit-without-learning context space))) (t (prime-commit-without-learning context " "))))) @@ -1407,7 +1407,7 @@ (let ((key-data (car key-list))) (cond ;; there's no speficied command then pressed key is passed. - ((= key-list '()) + ((eq? key-list '()) (prime-context-set-app-mode-key-list! context prime-app-mode-end-stroke-list) (prime-commit-raw context)) @@ -1770,20 +1770,20 @@ (lambda (context) (let ((diff (prime-context-history-compare context))) (cond - ((= diff 'state) + ((eq? diff 'state) (let ((state (prime-context-state context)) (last-word (prime-context-last-word context))) (cond - ((= state 'prime-state-preedit) + ((eq? state 'prime-state-preedit) (prime-convert-get-prediction context)) - ((= state 'prime-state-converting) + ((eq? state 'prime-state-converting) ;; Do nothing. (prime-convert-get-conversion context) had been ;; already executed at prime-convert-start-internal ) - ((= state 'prime-state-fund) + ((eq? state 'prime-state-fund) (prime-context-set-candidates! context '())) ))) - ((= diff 'preedit) + ((eq? diff 'preedit) (prime-convert-get-prediction context)) )))) @@ -1791,13 +1791,13 @@ (lambda (context) (let ((diff (prime-context-history-compare context))) (cond - ((= diff 'state) + ((eq? diff 'state) (let ((state (prime-context-state context))) (cond - ((= state 'prime-state-fund) + ((eq? state 'prime-state-fund) (im-deactivate-candidate-selector context)) - ((= state 'prime-state-preedit) + ((eq? state 'prime-state-preedit) (if (> (prime-get-nr-candidates context) 0) (im-activate-candidate-selector context @@ -1805,15 +1805,15 @@ 3))) ; prime-nr-candidate-max))) - ((= state 'prime-state-converting) + ((eq? state 'prime-state-converting) (im-activate-candidate-selector context (prime-get-nr-candidates context) prime-nr-candidate-max) (im-select-candidate context (prime-context-nth context))) - ((= state 'prime-state-modifying) + ((eq? state 'prime-state-modifying) (im-deactivate-candidate-selector context)) - ((= state 'prime-state-segment) + ((eq? state 'prime-state-segment) (im-activate-candidate-selector context (prime-segment-get-candidates-length context) @@ -1821,12 +1821,12 @@ (im-select-candidate context (prime-context-segment-nth context))) ))) - ((= diff 'nth) - (if (= (prime-context-state context) 'prime-state-segment) + ((eq? diff 'nth) + (if (eq? (prime-context-state context) 'prime-state-segment) (im-select-candidate context (prime-context-segment-nth context)) (im-select-candidate context (prime-context-nth context)))) - ((= diff 'preedit) + ((eq? diff 'preedit) (if (> (prime-get-nr-candidates context) 0) (im-activate-candidate-selector context (prime-get-nr-candidates context) prime-nr-candidate-max) @@ -1859,12 +1859,12 @@ (lambda (context) (let* ((state (prime-context-state context))) (cond - ((= state 'prime-state-converting) + ((eq? state 'prime-state-converting) (list (cons 'converting (prime-get-current-candidate context)) (cons 'cursor ""))) - ((or (= state 'prime-state-modifying) - (= state 'prime-state-segment)) + ((or (eq? state 'prime-state-modifying) + (eq? state 'prime-state-segment)) (let* ((line (prime-context-modification context))) (list (cons 'segment (nth 0 line)) (cons 'segment-highlight (nth 1 line)) @@ -2026,7 +2026,7 @@ (define prime-get-candidate-handler (lambda (context index-no accel-enum-hint) (let ((candidate - (if (= (prime-context-state context) 'prime-state-segment) + (if (eq? (prime-context-state context) 'prime-state-segment) (nth index-no (prime-context-segment-candidates context)) (nth index-no (prime-context-candidates context))))) ;; The return value is a list with a candidate string and the next index. @@ -2042,18 +2042,18 @@ (state (prime-context-state context))) (if (and prime-custom-display-form? form - (or (= state 'prime-state-converting) - (= state 'prime-state-segment))) + (or (eq? state 'prime-state-converting) + (eq? state 'prime-state-segment))) (set! string (string-append string " (" form ")"))) (if (and prime-custom-display-usage? usage - (or (= state 'prime-state-converting) - (= state 'prime-state-segment))) + (or (eq? state 'prime-state-converting) + (eq? state 'prime-state-segment))) (set! string (string-append string "\t▽" usage))) (if (and prime-custom-display-comment? comment - (or (= state 'prime-state-converting) - (= state 'prime-state-segment))) + (or (eq? state 'prime-state-converting) + (eq? state 'prime-state-segment))) (set! string (string-append string "\t<" comment ">"))) string))) @@ -2070,7 +2070,7 @@ (print "prime-set-candidate-index-handler") (if (prime-context-session context) (begin - (if (= (prime-context-state context) 'prime-state-segment) + (if (eq? (prime-context-state context) 'prime-state-segment) (prime-commit-segment-nth context selection-index) (prime-commit-candidate context selection-index)) (prime-update context) diff -Nur ./scm/spellcheck.scm ../.r5rs/scm/spellcheck.scm --- ./scm/spellcheck.scm 2005-03-11 01:26:50.000000000 -0800 +++ ../.r5rs/scm/spellcheck.scm 2005-08-31 21:31:30.000000000 -0700 @@ -141,7 +141,7 @@ (define spell-make-assoc-list (lambda (lst) - (mapcar + (map (lambda (str) (string-split str "=")) lst))) @@ -174,7 +174,7 @@ (define spell-parse-cands (lambda (cands-string) - (mapcar + (map (lambda (str-line) (string-split str-line "\t")) (cdr (delq "" (string-split cands-string "\n")))))) diff -Nur ./sigscheme/debug.c ../.r5rs/sigscheme/debug.c --- ./sigscheme/debug.c 2005-08-31 20:35:59.000000000 -0700 +++ ../.r5rs/sigscheme/debug.c 2005-08-31 22:21:56.000000000 -0700 @@ -77,19 +77,24 @@ #define INTERESTINGP(obj) \ (CONSP(obj) \ || (STRINGP(obj) && SCM_STRING_LEN(obj)) \ - || VECTORP(obj)) + || CLOSUREP(obj) \ + || VECTORP(obj) \ + || VALUEPACKETP(obj)) #define SCM_INVALID NULL #define OCCUPIED(ent) (!EQ((ent)->key, SCM_INVALID)) #define HASH_EMPTY(table) (!(table).used) -#define DEFINING_DATUM (-1) +#define DEFINING_DATUM (-1) +#define NONDEFINING_DATUM 0 #define GET_DEFINDEX(x) ((unsigned)(x) >> 1) +#define HASH_INSERT 1 /* insert key if it's not registered yet */ +#define HASH_FIND 0 #endif /* SCM_USE_SRFI38 */ /*======================================= Variable Declarations =======================================*/ #if SCM_USE_SRFI38 -static write_ss_context *write_ss_ctx; /* list of shared structures in the object we're writing out */ +static write_ss_context *write_ss_ctx; /* misc info in priting shared structures */ #endif /*======================================= @@ -105,7 +110,7 @@ #if SCM_USE_SRFI38 static void hash_grow(hash_table *tab); -static hash_entry *hash_lookup(hash_table *tab, ScmObj key, int insert); +static hash_entry *hash_lookup(hash_table *tab, ScmObj key, int datum, int flag); static void write_ss_scan(ScmObj obj, write_ss_context *ctx); static int get_shared_index(ScmObj obj); #endif /* SCM_USE_SRFI38 */ @@ -406,17 +411,13 @@ size_t new_size = old_size * 2; size_t i; hash_entry *old_ents = tab->ents; - hash_entry *new_ent; tab->ents = calloc(new_size, sizeof(hash_entry)); tab->size = new_size; + tab->used = 0; - for (i=0; i < old_size; i++) { - /* Don't change the last argument, or hash_lookup() will call - * us again. */ - new_ent = hash_lookup(tab, old_ents[i].key, 0); - *new_ent = old_ents[i]; - } + for (i=0; i < old_size; i++) + hash_lookup(tab, old_ents[i].key, old_ents[i].datum, HASH_INSERT); free (old_ents); } @@ -424,7 +425,7 @@ /** * @return A pointer to the entry, or NULL if not found. */ -static hash_entry *hash_lookup(hash_table *tab, ScmObj key, int insert) +static hash_entry *hash_lookup(hash_table *tab, ScmObj key, int datum, int flag) { size_t i; unsigned hashval; @@ -450,14 +451,14 @@ for (i=0; i < tab->size; i++) { ent = &(tab->ents)[(hashval + i) & (tab->size - 1)]; if (!OCCUPIED(ent)) { - if (insert) { - /* used > size * 2/3 --> overpopulated, grow table */ - if (tab->used * 3 > tab->size * 2) { - hash_grow(tab); - return hash_lookup(tab, key, 1); - } + if (flag & HASH_INSERT) { ent->key = key; + ent->datum = datum; tab->used++; + + /* used > size * 2/3 --> overpopulated */ + if (tab->used * 3 > tab->size * 2) + hash_grow(tab); } return NULL; } @@ -480,7 +481,7 @@ hash_entry *ent; /* (for-each mark-as-seen-or-return-if-familiar obj) */ while (CONSP(obj)) { - ent = hash_lookup(&ctx->seen, obj, 1); + ent = hash_lookup(&ctx->seen, obj, NONDEFINING_DATUM, HASH_INSERT); if (ent) { ent->datum = DEFINING_DATUM; return; @@ -489,22 +490,30 @@ obj = CDR(obj); } - if (VECTORP(obj)) { - ent = hash_lookup(&ctx->seen, obj, 1); + if (INTERESTINGP(obj)) { + ent = hash_lookup(&ctx->seen, obj, NONDEFINING_DATUM, HASH_INSERT); if (ent) { ent->datum = DEFINING_DATUM; return; } - for (i=0; i < SCM_VECTOR_LEN(obj); i++) - write_ss_scan(SCM_VECTOR_CREF(obj, i), ctx); - return; - } - if (STRINGP(obj) && SCM_STRING_LEN(obj)) { - ent = hash_lookup(&ctx->seen, obj, 1); - if (ent) { - ent->datum = DEFINING_DATUM; - return; - } + switch (SCM_TYPE(obj)) { + case ScmClosure: + /* We don't need to track env because it's not printed anyway. */ + write_ss_scan(SCM_CLOSURE_EXP(obj), ctx); + break; + + case ScmValuePacket: + write_ss_scan(SCM_VALUEPACKET_VALUES(obj), ctx); + break; + + case ScmVector: + for (i=0; i < SCM_VECTOR_LEN(obj); i++) + write_ss_scan(SCM_VECTOR_CREF(obj, i), ctx); + break; + + default: + break; + } } } @@ -519,7 +528,7 @@ hash_entry *ent; if (write_ss_ctx) { - ent = hash_lookup(&write_ss_ctx->seen, obj, 0); + ent = hash_lookup(&write_ss_ctx->seen, obj, 0, HASH_FIND); if (ent->datum == DEFINING_DATUM) { ent->datum = write_ss_ctx->next_index++; diff -Nur ./sigscheme/test/test-srfi38.scm ../.r5rs/sigscheme/test/test-srfi38.scm --- ./sigscheme/test/test-srfi38.scm 1969-12-31 16:00:00.000000000 -0800 +++ ../.r5rs/sigscheme/test/test-srfi38.scm 2005-08-31 20:01:04.000000000 -0700 @@ -0,0 +1,21 @@ +;; No assertive tests for now, just print something and see if we bloat. +;(load "test/unittest.scm") + +(let* ((s "abc") + (convolution `(,s 1 #(,s b) (2) () ,s))) + ; go crazy with mutators + (set-car! (cdr convolution) convolution) + (vector-set! (caddr convolution) 1 (cddr convolution)) + (set-cdr! (cadddr convolution) (cdr convolution)) + (write-with-shared-structure convolution)) +(display " <-- computed output\n") +(display "#1=(#2=\"abc\" . #3=(#1# . #4=(#(#2# #4#) (2 . #3#) () #2#))) <-- expected output\n") + +(let* ((a-pair '(kar . kdr)) + (convolution (eval (list 'lambda () a-pair) (scheme-report-environment 5)))) + (set-cdr! a-pair convolution) + (write-with-shared-structure convolution)) +(display " <-- computed output\n") +(display "#1=#<closure:(() (kar . #1#))> <-- expected output\n") + +;(total-report) diff -Nur ./uim/uim.c ../.r5rs/uim/uim.c -------------- next part -------------- --- ./uim/uim.c 2005-08-31 20:36:00.000000000 -0700 +++ ../.r5rs/uim/uim.c 2005-09-01 01:45:32.000000000 -0700 @@ -97,9 +97,9 @@ static void put_context_id(uim_context uc) { - UIM_LOCK_MUTEX(context_array_mtx); + if (!UIM_ATOMIC(uc)) UIM_LOCK_MUTEX(context_array_mtx); context_array[uc->id] = NULL; - UIM_UNLOCK_MUTEX(context_array_mtx); + if (!UIM_ATOMIC(uc)) UIM_UNLOCK_MUTEX(context_array_mtx); } uim_context @@ -289,9 +289,11 @@ uim_context uim_find_context(int id) { - UIM_LOCK_MUTEX(context_array_mtx); - return context_array[id]; - UIM_UNLOCK_MUTEX(context_array_mtx); + uim_context ret; + if (!UIM_ATOMIC(ret)) UIM_LOCK_MUTEX(context_array_mtx); + ret = context_array[id]; + if (!UIM_ATOMIC(ret)) UIM_UNLOCK_MUTEX(context_array_mtx); + return ret; } int
