← Back to branch summary

~ubuntu-branches/ubuntu/maverick/uim/maverick

« back to all changes in this revision

Viewing changes to scm/custom.scm

  • Committer: Bazaar Package Importer
  • Author(s): Masahito Omote
  • Date: 2008-06-25 19:56:33 UTC
  • mfrom: (3.1.18 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080625195633-8jljph4rfq00l8o7
Tags: 1:1.5.1-2
http://bugs.debian.org/482659
http://bugs.debian.org/483078
* uim-tcode: provide tutcode-custom.scm, tutcode-bushudic.scm
  and tutcode-rule.scm (Closes: #482659)
* Fix FTBFS: segv during compile (Closes: #483078).
  I personally think this bug is not specific for uim but is a optimization
  problem on gcc-4.3.1. (https://bugs.freedesktop.org/show_bug.cgi?id=16477)

Show diffs side-by-side

added added

removed removed

Lines of Context:
scm/custom.scm
1
1
;;; custom.scm: Customization support
2
2
;;;
3
 
;;; Copyright (c) 2003-2006 uim Project http://uim.freedesktop.org/
 
3
;;; Copyright (c) 2003-2008 uim Project http://code.google.com/p/uim/
4
4
;;;
5
5
;;; All rights reserved.
6
6
;;;
183
183
;; TODO: write test
184
184
(define map-key-list-letter
185
185
  (lambda (letter-mapper key-list)
186
 
    (let ((letter (string->letter (find string? key-list))))
 
186
    (let ((letter (string->alphabetic-ichar (find string? key-list))))
187
187
      (map-key-list-body (lambda (elem)
188
188
                           (if letter
189
189
                               (charcode->string (letter-mapper letter))
201
201
;; TODO: write test
202
202
(define key-list-upcase
203
203
  (lambda (key-list)
204
 
    (map-key-list-letter char-upcase key-list)))
 
204
    (map-key-list-letter ichar-upcase key-list)))
205
205
 
206
206
;; TODO: write test
207
207
(define key-list-downcase
208
208
  (lambda (key-list)
209
 
    (map-key-list-letter char-downcase key-list)))
 
209
    (map-key-list-letter ichar-downcase key-list)))
210
210
 
211
211
;; TODO: write test
212
212
(define key-list-visualize-space
231
231
  (lambda (key-list)
232
232
    (let* ((has-shift? (memq 'Shift_key key-list))
233
233
           (str (find string? key-list))
234
 
           (printable (string->printable-char str))
235
 
           (letter (string->letter str)))
 
234
           (printable (string->printable-ichar str))
 
235
           (letter (string->alphabetic-ichar str)))
236
236
      (filter-map (lambda (elem)
237
237
                    (cond
238
238
                     ((and (eq? elem 'Shift_key)
239
 
                           (char-graphic? printable))
 
239
                           (ichar-graphic? printable))
240
240
                      #f)
241
241
                     ((and (string? elem)
242
242
                           has-shift?
243
243
                           letter)
244
 
                      (charcode->string (char-upcase letter)))
 
244
                      (charcode->string (ichar-upcase letter)))
245
245
                     ((and (string? elem)
246
246
                           has-shift?
247
 
                           (char-graphic? printable))
 
247
                           (ichar-graphic? printable))
248
248
                      str)
249
249
                     (else
250
250
                      elem)))
253
253
;; TODO: write test
254
254
(define key-list-decode-shift
255
255
  (lambda (key-list)
256
 
    (let* ((letter (string->letter (find string? key-list)))
 
256
    (let* ((letter (string->alphabetic-ichar (find string? key-list)))
257
257
           (upper-case? (and letter
258
 
                             (char-upper-case? letter)))
 
258
                             (ichar-upper-case? letter)))
259
259
           (has-shift? (memq 'Shift_key key-list))
260
260
           (stripped (key-list-downcase key-list)))
261
261
      (if (and (not has-shift?)
266
266
;; TODO: write test
267
267
(define key-list-ignore-regular-shift
268
268
  (lambda (key-list)
269
 
    (let ((printable (string->printable-char (find string? key-list))))
270
 
      (if (char-graphic? printable)
 
269
    (let ((printable (string->printable-ichar (find string? key-list))))
 
270
      (if (ichar-graphic? printable)
271
271
          (cons 'IgnoreRegularShift key-list)
272
272
          key-list))))
273
273
 
274
274
;; TODO: write test
275
275
(define key-list-ignore-letter-shift
276
276
  (lambda (key-list)
277
 
    (let ((letter (string->letter (find string? key-list))))
 
277
    (let ((letter (string->alphabetic-ichar (find string? key-list))))
278
278
      (if letter
279
279
          (cons 'IgnoreShift key-list)
280
280
          key-list))))
283
283
(define key-list-ignore-punct-numeric-shift
284
284
  (lambda (key-list)
285
285
    (let* ((str (find string? key-list))
286
 
           (c (string->printable-char str)))
287
 
      (if (and (char-graphic? c)
288
 
               (not (char-alphabetic? c)))
 
286
           (c (string->printable-ichar str)))
 
287
      (if (and (ichar-graphic? c)
 
288
               (not (ichar-alphabetic? c)))
289
289
          (cons 'IgnoreShift key-list)
290
290
          key-list))))
291
291
 
292
292
;; TODO: write test
293
293
(define key-list-ignore-case
294
294
  (lambda (key-list)
295
 
    (let ((letter (string->letter (find string? key-list))))
 
295
    (let ((letter (string->alphabetic-ichar (find string? key-list))))
296
296
      (if letter
297
297
          (cons 'IgnoreCase key-list)
298
298
          key-list))))
306
306
(define key-list-strip-regular-shift
307
307
  (lambda (key-list)
308
308
    (let* ((str (find string? key-list))
309
 
           (printable (string->printable-char str)))
310
 
      (if (char-graphic? printable)
 
309
           (printable (string->printable-ichar str)))
 
310
      (if (ichar-graphic? printable)
311
311
          (key-list-strip-shift key-list)
312
312
          key-list))))
313
313
 
568
568
           (if (eq? (custom-type sym)
569
569
                    'key)
570
570
               (let ((key-val (custom-modify-key-predicate-names val)))
571
 
                 (eval (list 'define (symbolconc sym '?)
 
571
                 (eval (list 'define (symbol-append sym '?)
572
572
                             (list 'make-key-predicate (list 'quote key-val)))
573
573
                       (interaction-environment))))
574
574
           (custom-call-hook-procs sym custom-set-hooks)
675
675
                                 (else
676
676
                                  "")))
677
677
                              lst)))
678
 
      (string-append "'(" (string-join " " canonicalized) ")"))))
 
678
      (string-append "'(" (string-join canonicalized " ") ")"))))
679
679
 
680
680
;; API
681
681
(define custom-value-as-literal
684
684
          (type (custom-type sym)))
685
685
      (cond
686
686
       ((eq? type 'integer)
687
 
        (digit->string val))
 
687
        (number->string val))
688
688
       ((eq? type 'string)
689
689
        (string-escape val))
690
690
       ((eq? type 'pathname)
707
707
          (val (custom-value-as-literal sym))
708
708
          (hooked (custom-call-hook-procs sym custom-literalize-hooks)))
709
709
      (if (not (null? hooked))
710
 
          (string-join "\n" hooked)
 
710
          (string-join hooked "\n")
711
711
          (apply string-append
712
712
                 (append
713
713
                  (list "(define " var " " val ")")
724
724
;; TODO: implement after uim 0.4.6 depending on scm-nested-eval
725
725
(define custom-broadcast-custom
726
726
  (lambda (sym)
727
 
    ))
 
727
  #f))
728
728
 
729
729
;; API
730
730
;; #f means 'any group'
734
734
    (let ((custom-syms (custom-collect-by-group group)))
735
735
      (for-each custom-broadcast-custom custom-syms))))
736
736
 
737
 
(define custom-prop-update-custom-handler
738
 
  (lambda (context custom-sym val)
739
 
    (custom-set-value! custom-sym val)))
740
 
 
741
737
(define custom-register-cb
742
738
  (lambda (hook valid? custom-sym ptr gate-func func)
743
739
    (and (valid? custom-sym)
749
745
;;
750
746
 
751
747
(define-custom-group 'main
752
 
                     (_ "-")
753
 
                     (_ "Main settings of this group"))
 
748
                     (N_ "-")
 
749
                     (N_ "Main settings of this group"))
754
750
 
755
751
(define-custom-group 'hidden
756
 
                     (_ "Hidden settings")
757
 
                     (_ "Hidden settings of this group. This group is invisible from uim_custom clients. Exists for internal variable management."))
 
752
                     (N_ "Hidden settings")
 
753
                     (N_ "Hidden settings of this group. This group is invisible from uim_custom clients. Exists for internal variable management."))
758
754
 
759
755
 
760
756
(prealloc-heaps-for-heavy-job)