Changeset 27151 in project


Ignore:
Timestamp:
08/01/12 16:00:18 (9 years ago)
Author:
Alex Shinn
Message:

Porting free-gettext test suites from Gauche and fixing plural lookup.

Location:
release/4/free-gettext
Files:
16 added
4 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/free-gettext/tags/1.4/free-gettext.scm

    r24882 r27151  
    11;; gettext.scm -- gettext superset implemented in Scheme
    22;;
    3 ;; Copyright (c) 2003-2011 Alex Shinn.  All rights reserved.
     3;; Copyright (c) 2003-2012 Alex Shinn.  All rights reserved.
    44;; BSD-style license: http://synthcode.com/license.txt
    55
     
    326326                    ((string-prefix? "msgstr[" line))
    327327                    (i (string-index line #\] 7))
    328                     (n (string->number (substring line 8 i)))
     328                    (n (string->number (substring line 7 i)))
    329329                    (str (call-with-input-string
    330330                             (substring/shared line (+ i 1))
    331331                           read))
    332332                    ((string? str)))
    333            (cons n str))
     333           (cons n (read-str str)))
    334334         => (lambda (x) (reader (cons x res))))
    335335        (else (reverse res)))))
     
    451451    (let loop ((c (read-char)))
    452452      (if (eof-object? c)
    453         c ;; maybe signal error
    454         (if (eqv? c #\*)
    455           (let ((c2 (read-char)))
    456             (if (eqv? c2 #\/) #f (loop c2)))
    457           (loop (read-char))))))
     453          c ;; maybe signal error
     454          (if (eqv? c #\*)
     455              (let ((c2 (read-char)))
     456                (if (eqv? c2 #\/) #f (loop c2)))
     457              (loop (read-char))))))
    458458  (define (next-token)
    459459    (let ((c (read-char)))
    460460      (if (eof-object? c)
    461         c
    462         (case c
    463           ((#\() 'open)
    464           ((#\)) 'close)
    465           ((#\/) (if (eqv? (peek-char) #\*) (read-comment) '/))
    466           ((#\- #\+ #\* #\% #\? #\:)
    467            (string->symbol (string c)))
    468           ((#\&) (if (eqv? (peek-char) c) (begin (read-char) 'and) 'logand))
    469           ((#\|) (if (eqv? (peek-char) c) (begin (read-char) 'or) 'logior))
    470           ((#\! #\> #\<)
    471            (cond ((eqv? (peek-char) #\=)
    472                   (read-char) (string->symbol (string c #\=)))
    473                  (else (string->symbol (string c)))))
    474           ((#\=)
    475            (cond ((eqv? (peek-char) #\=) (read-char) '==)
    476                  (else (warning "invalid assignment in C code") #f)))
    477           ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
    478            (read-number c))
    479           ((#\n) 'n)
    480           ((#\space #\newline) (next-token))
    481           (else (warning "invalid character in C code: ~S" c) #f)))))
     461          c
     462          (case c
     463            ((#\() 'open)
     464            ((#\)) 'close)
     465            ((#\/) (if (eqv? (peek-char) #\*) (read-comment) '/))
     466            ((#\- #\+ #\* #\% #\? #\:)
     467             (string->symbol (string c)))
     468            ((#\&) (if (eqv? (peek-char) c) (begin (read-char) 'and) 'logand))
     469            ((#\|) (if (eqv? (peek-char) c) (begin (read-char) 'or) 'logior))
     470            ((#\! #\> #\<)
     471             (cond ((eqv? (peek-char) #\=)
     472                    (read-char) (string->symbol (string c #\=)))
     473                   (else (string->symbol (string c)))))
     474            ((#\=)
     475             (cond ((eqv? (peek-char) #\=) (read-char) '==)
     476                   (else (warning "invalid assignment in C code") #f)))
     477            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
     478             (read-number c))
     479            ((#\n) 'n)
     480            ((#\space #\newline) (next-token))
     481            (else (warning "invalid character in C code: ~S" c) #f)))))
    482482  (define (C-parse str)
    483483    (define (precedence x) ;; lower value is higher precedence
     
    499499      (define (group op left right)
    500500        (cond
    501           ((or (eq? right end) (eq? right 'eof))
    502            (warning "expected 2nd argument to" op)
    503            `(op ,left))
    504           ((eq? op 'and)
    505            `(if (zero? ,left) 0 ,right))
    506           ((eq? op 'or)
    507            `(if (zero? ,left) ,right 1))
    508           (else
    509            `(,op ,left ,right))))
     501         ((or (eq? right end) (eq? right 'eof))
     502          (warning "expected 2nd argument to" op)
     503          `(op ,left))
     504         ((eq? op 'and)
     505          `(if (zero? ,left) 0 ,right))
     506         ((eq? op 'or)
     507          `(if (zero? ,left) ,right 1))
     508         (else
     509          `(,op ,left ,right))))
    510510      (define (join x stack)
    511511        (if (null? stack)
    512           x
    513           (join (group (car stack) (cadr stack) x) (cddr stack))))
     512            x
     513            (join (group (car stack) (cadr stack) x) (cddr stack))))
    514514      (let ((init (parse1)))
    515515        (if (equal? init end)
    516           '()
    517           (let parse ((left init) (op (parse1)) (stack '()))
    518             (cond
    519               ((eq? op end) (join left stack))
    520               ((eq? op 'eof)
    521                (warning "unexpected #<eof>")
    522                (join left stack))
    523               ((eq? op '?) ;; trinary ? : (right-assoc)
    524                (let* ((pass (parse-until ':))
    525                       (fail (parse1))
    526                       (op2 (parse1)))
    527                  (cond
     516            '()
     517            (let parse ((left init) (op (parse1)) (stack '()))
     518              (cond
     519               ((eq? op end) (join left stack))
     520               ((eq? op 'eof)
     521                (warning "unexpected #<eof>")
     522                (join left stack))
     523               ((eq? op '?) ;; trinary ? : (right-assoc)
     524                (let* ((pass (parse-until ':))
     525                       (fail (parse1))
     526                       (op2 (parse1)))
     527                  (cond
    528528                   ((or (eq? op2 end) (eq? op2 'eof))
    529529                    `(if (zero? ,left) ,fail ,pass))
     
    533533                    (join `(if (zero? ,left) ,(parse fail op2 '()) ,pass)
    534534                          stack)))))
    535               (else ;; assume a (left-assoc) binary operator
    536                (let* ((right (parse1))
    537                       (op2 (parse1)))
    538                  (cond
     535               (else ;; assume a (left-assoc) binary operator
     536                (let* ((right (parse1))
     537                       (op2 (parse1)))
     538                  (cond
    539539                   ((or (eq? op2 end) (eq? op2 'eof))
    540540                    (join (group op left right) stack))
     
    544544                      (if (and (pair? s)
    545545                               (< (precedence (car s)) (precedence op2)))
    546                         (loop2 (group (car s) (cadr s) x) (cddr s))
    547                         (parse x op2 s))))
     546                          (loop2 (group (car s) (cadr s) x) (cddr s))
     547                          (parse x op2 s))))
    548548                   (else
    549549                    ;; op2 has higher precedence, push on the stack
     
    553553  (define (map-C-names x)
    554554    (cond
    555       ((symbol? x)
    556        (case x
    557          ((/) 'quotient) ((%) 'modulo) ((**) 'expt)
    558          ((~) 'lognot)   ((^) 'logxor) ((<<) 'arithmetic-shift)
    559          ;; C conflates booleans with integers
    560          ((!) '(lambda (a) (if (zero? a) 1 0)))
    561          ((>>) '(lambda (a b) (arithmetic-shift a (- b))))
    562          ((==) '(lambda (a b) (if (eqv? a b) 1 0)))
    563          ((!=) '(lambda (a b) (if (eqv? a b) 0 1)))
    564          ((>) '(lambda (a b)  (if (> a b) 1 0)))
    565          ((<) '(lambda (a b)  (if (< a b) 1 0)))
    566          ((>=) '(lambda (a b) (if (>= a b) 1 0)))
    567          ((<=) '(lambda (a b) (if (<= a b) 1 0)))
    568          (else x)))
    569       ((pair? x)
    570        (cons (map-C-names (car x)) (map-C-names (cdr x))))
    571       (else x)))
     555     ((symbol? x)
     556      (case x
     557        ((/) 'quotient) ((%) 'modulo) ((**) 'expt)
     558        ((~) 'lognot)   ((^) 'logxor) ((<<) 'arithmetic-shift)
     559        ;; C conflates booleans with integers
     560        ((!) '(lambda (a) (if (zero? a) 1 0)))
     561        ((>>) '(lambda (a b) (arithmetic-shift a (- b))))
     562        ((==) '(lambda (a b) (if (eqv? a b) 1 0)))
     563        ((!=) '(lambda (a b) (if (eqv? a b) 0 1)))
     564        ((>) '(lambda (a b)  (if (> a b) 1 0)))
     565        ((<) '(lambda (a b)  (if (< a b) 1 0)))
     566        ((>=) '(lambda (a b) (if (>= a b) 1 0)))
     567        ((<=) '(lambda (a b) (if (<= a b) 1 0)))
     568        (else x)))
     569     ((pair? x)
     570      (cons (map-C-names (car x)) (map-C-names (cdr x))))
     571     (else x)))
    572572  (let ((body (map-C-names (C-parse str))))
    573573    ;; could build from chained closures w/o using eval but this is
     
    611611    (define (search msg . opt)
    612612      (if (and cached? (hash-table-exists? cache msg))
    613         (hash-table-ref/default cache msg #f)
    614         (let-optionals* opt ((msg2 #f) (n #f))
    615           (let ((split? (number? n)))
    616             (any
    617              (lambda (gf)
    618                (and-let* ((x0 (lookup-message gf msg msg2))
    619                           (x (if (and split? (eq? (gfile-type gf) 'mo))
    620                                (cons (or msg2 msg)
    621                                      (let ((l (string-split x0 null-str)))
    622                                        (map cons (iota (length l)) l)))
    623                                x0))
    624                           (res (cons x gf)))
    625                  (if cached? (hash-table-set! cache msg res))
    626                  res))
    627              files)))))
     613          (hash-table-ref/default cache msg #f)
     614          (let-optionals* opt ((msg2 #f) (n #f))
     615            (let ((split? (number? n)))
     616              (any
     617               (lambda (gf)
     618                 (and-let* ((x0 (lookup-message gf msg msg2))
     619                            (x (if (and split? (eq? (gfile-type gf) 'mo))
     620                                   (cons (or msg2 msg)
     621                                         (let ((l (string-split x0 null-str)))
     622                                           (map cons (iota (length l)) l)))
     623                                   x0))
     624                            (res (cons x gf)))
     625                   (if cached? (hash-table-set! cache msg res))
     626                   res))
     627               files)))))
    628628
    629629    (define (get msg)
     
    640640        (let ((res (search msg msg2 n)))
    641641          (if (pair? res)
    642             (let ((plural-index (gfile-plural-index (cdr res))))
    643               (or (and (procedure? plural-index)
    644                        (cond
    645                         ((assv (cdar res) (plural-index (or n 1))) => cdr)
    646                         (else #f)))
    647                   (if (eqv? n 1) msg (caar res))))
    648             (if (or (eqv? n 1) (not msg2)) msg msg2)))))
     642              (let ((plural-index (gfile-plural-index (cdr res))))
     643                (or (and (procedure? plural-index)
     644                         (cond
     645                          ((assv (plural-index (or n 1)) (cdar res)) => cdr)
     646                          (else #f)))
     647                    (if (eqv? n 1) msg (caar res))))
     648              (if (or (eqv? n 1) (not msg2)) msg msg2)))))
    649649
    650650    (define (set msg val) (hash-table-set! cache msg val))
  • release/4/free-gettext/tags/1.4/free-gettext.setup

    r24882 r27151  
    77 'free-gettext
    88 '("free-gettext.so" "free-gettext.import.so")
    9  '((version 1.3)))
     9 '((version 1.4)))
  • release/4/free-gettext/trunk/free-gettext.scm

    r24882 r27151  
    11;; gettext.scm -- gettext superset implemented in Scheme
    22;;
    3 ;; Copyright (c) 2003-2011 Alex Shinn.  All rights reserved.
     3;; Copyright (c) 2003-2012 Alex Shinn.  All rights reserved.
    44;; BSD-style license: http://synthcode.com/license.txt
    55
     
    326326                    ((string-prefix? "msgstr[" line))
    327327                    (i (string-index line #\] 7))
    328                     (n (string->number (substring line 8 i)))
     328                    (n (string->number (substring line 7 i)))
    329329                    (str (call-with-input-string
    330330                             (substring/shared line (+ i 1))
    331331                           read))
    332332                    ((string? str)))
    333            (cons n str))
     333           (cons n (read-str str)))
    334334         => (lambda (x) (reader (cons x res))))
    335335        (else (reverse res)))))
     
    451451    (let loop ((c (read-char)))
    452452      (if (eof-object? c)
    453         c ;; maybe signal error
    454         (if (eqv? c #\*)
    455           (let ((c2 (read-char)))
    456             (if (eqv? c2 #\/) #f (loop c2)))
    457           (loop (read-char))))))
     453          c ;; maybe signal error
     454          (if (eqv? c #\*)
     455              (let ((c2 (read-char)))
     456                (if (eqv? c2 #\/) #f (loop c2)))
     457              (loop (read-char))))))
    458458  (define (next-token)
    459459    (let ((c (read-char)))
    460460      (if (eof-object? c)
    461         c
    462         (case c
    463           ((#\() 'open)
    464           ((#\)) 'close)
    465           ((#\/) (if (eqv? (peek-char) #\*) (read-comment) '/))
    466           ((#\- #\+ #\* #\% #\? #\:)
    467            (string->symbol (string c)))
    468           ((#\&) (if (eqv? (peek-char) c) (begin (read-char) 'and) 'logand))
    469           ((#\|) (if (eqv? (peek-char) c) (begin (read-char) 'or) 'logior))
    470           ((#\! #\> #\<)
    471            (cond ((eqv? (peek-char) #\=)
    472                   (read-char) (string->symbol (string c #\=)))
    473                  (else (string->symbol (string c)))))
    474           ((#\=)
    475            (cond ((eqv? (peek-char) #\=) (read-char) '==)
    476                  (else (warning "invalid assignment in C code") #f)))
    477           ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
    478            (read-number c))
    479           ((#\n) 'n)
    480           ((#\space #\newline) (next-token))
    481           (else (warning "invalid character in C code: ~S" c) #f)))))
     461          c
     462          (case c
     463            ((#\() 'open)
     464            ((#\)) 'close)
     465            ((#\/) (if (eqv? (peek-char) #\*) (read-comment) '/))
     466            ((#\- #\+ #\* #\% #\? #\:)
     467             (string->symbol (string c)))
     468            ((#\&) (if (eqv? (peek-char) c) (begin (read-char) 'and) 'logand))
     469            ((#\|) (if (eqv? (peek-char) c) (begin (read-char) 'or) 'logior))
     470            ((#\! #\> #\<)
     471             (cond ((eqv? (peek-char) #\=)
     472                    (read-char) (string->symbol (string c #\=)))
     473                   (else (string->symbol (string c)))))
     474            ((#\=)
     475             (cond ((eqv? (peek-char) #\=) (read-char) '==)
     476                   (else (warning "invalid assignment in C code") #f)))
     477            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
     478             (read-number c))
     479            ((#\n) 'n)
     480            ((#\space #\newline) (next-token))
     481            (else (warning "invalid character in C code: ~S" c) #f)))))
    482482  (define (C-parse str)
    483483    (define (precedence x) ;; lower value is higher precedence
     
    499499      (define (group op left right)
    500500        (cond
    501           ((or (eq? right end) (eq? right 'eof))
    502            (warning "expected 2nd argument to" op)
    503            `(op ,left))
    504           ((eq? op 'and)
    505            `(if (zero? ,left) 0 ,right))
    506           ((eq? op 'or)
    507            `(if (zero? ,left) ,right 1))
    508           (else
    509            `(,op ,left ,right))))
     501         ((or (eq? right end) (eq? right 'eof))
     502          (warning "expected 2nd argument to" op)
     503          `(op ,left))
     504         ((eq? op 'and)
     505          `(if (zero? ,left) 0 ,right))
     506         ((eq? op 'or)
     507          `(if (zero? ,left) ,right 1))
     508         (else
     509          `(,op ,left ,right))))
    510510      (define (join x stack)
    511511        (if (null? stack)
    512           x
    513           (join (group (car stack) (cadr stack) x) (cddr stack))))
     512            x
     513            (join (group (car stack) (cadr stack) x) (cddr stack))))
    514514      (let ((init (parse1)))
    515515        (if (equal? init end)
    516           '()
    517           (let parse ((left init) (op (parse1)) (stack '()))
    518             (cond
    519               ((eq? op end) (join left stack))
    520               ((eq? op 'eof)
    521                (warning "unexpected #<eof>")
    522                (join left stack))
    523               ((eq? op '?) ;; trinary ? : (right-assoc)
    524                (let* ((pass (parse-until ':))
    525                       (fail (parse1))
    526                       (op2 (parse1)))
    527                  (cond
     516            '()
     517            (let parse ((left init) (op (parse1)) (stack '()))
     518              (cond
     519               ((eq? op end) (join left stack))
     520               ((eq? op 'eof)
     521                (warning "unexpected #<eof>")
     522                (join left stack))
     523               ((eq? op '?) ;; trinary ? : (right-assoc)
     524                (let* ((pass (parse-until ':))
     525                       (fail (parse1))
     526                       (op2 (parse1)))
     527                  (cond
    528528                   ((or (eq? op2 end) (eq? op2 'eof))
    529529                    `(if (zero? ,left) ,fail ,pass))
     
    533533                    (join `(if (zero? ,left) ,(parse fail op2 '()) ,pass)
    534534                          stack)))))
    535               (else ;; assume a (left-assoc) binary operator
    536                (let* ((right (parse1))
    537                       (op2 (parse1)))
    538                  (cond
     535               (else ;; assume a (left-assoc) binary operator
     536                (let* ((right (parse1))
     537                       (op2 (parse1)))
     538                  (cond
    539539                   ((or (eq? op2 end) (eq? op2 'eof))
    540540                    (join (group op left right) stack))
     
    544544                      (if (and (pair? s)
    545545                               (< (precedence (car s)) (precedence op2)))
    546                         (loop2 (group (car s) (cadr s) x) (cddr s))
    547                         (parse x op2 s))))
     546                          (loop2 (group (car s) (cadr s) x) (cddr s))
     547                          (parse x op2 s))))
    548548                   (else
    549549                    ;; op2 has higher precedence, push on the stack
     
    553553  (define (map-C-names x)
    554554    (cond
    555       ((symbol? x)
    556        (case x
    557          ((/) 'quotient) ((%) 'modulo) ((**) 'expt)
    558          ((~) 'lognot)   ((^) 'logxor) ((<<) 'arithmetic-shift)
    559          ;; C conflates booleans with integers
    560          ((!) '(lambda (a) (if (zero? a) 1 0)))
    561          ((>>) '(lambda (a b) (arithmetic-shift a (- b))))
    562          ((==) '(lambda (a b) (if (eqv? a b) 1 0)))
    563          ((!=) '(lambda (a b) (if (eqv? a b) 0 1)))
    564          ((>) '(lambda (a b)  (if (> a b) 1 0)))
    565          ((<) '(lambda (a b)  (if (< a b) 1 0)))
    566          ((>=) '(lambda (a b) (if (>= a b) 1 0)))
    567          ((<=) '(lambda (a b) (if (<= a b) 1 0)))
    568          (else x)))
    569       ((pair? x)
    570        (cons (map-C-names (car x)) (map-C-names (cdr x))))
    571       (else x)))
     555     ((symbol? x)
     556      (case x
     557        ((/) 'quotient) ((%) 'modulo) ((**) 'expt)
     558        ((~) 'lognot)   ((^) 'logxor) ((<<) 'arithmetic-shift)
     559        ;; C conflates booleans with integers
     560        ((!) '(lambda (a) (if (zero? a) 1 0)))
     561        ((>>) '(lambda (a b) (arithmetic-shift a (- b))))
     562        ((==) '(lambda (a b) (if (eqv? a b) 1 0)))
     563        ((!=) '(lambda (a b) (if (eqv? a b) 0 1)))
     564        ((>) '(lambda (a b)  (if (> a b) 1 0)))
     565        ((<) '(lambda (a b)  (if (< a b) 1 0)))
     566        ((>=) '(lambda (a b) (if (>= a b) 1 0)))
     567        ((<=) '(lambda (a b) (if (<= a b) 1 0)))
     568        (else x)))
     569     ((pair? x)
     570      (cons (map-C-names (car x)) (map-C-names (cdr x))))
     571     (else x)))
    572572  (let ((body (map-C-names (C-parse str))))
    573573    ;; could build from chained closures w/o using eval but this is
     
    611611    (define (search msg . opt)
    612612      (if (and cached? (hash-table-exists? cache msg))
    613         (hash-table-ref/default cache msg #f)
    614         (let-optionals* opt ((msg2 #f) (n #f))
    615           (let ((split? (number? n)))
    616             (any
    617              (lambda (gf)
    618                (and-let* ((x0 (lookup-message gf msg msg2))
    619                           (x (if (and split? (eq? (gfile-type gf) 'mo))
    620                                (cons (or msg2 msg)
    621                                      (let ((l (string-split x0 null-str)))
    622                                        (map cons (iota (length l)) l)))
    623                                x0))
    624                           (res (cons x gf)))
    625                  (if cached? (hash-table-set! cache msg res))
    626                  res))
    627              files)))))
     613          (hash-table-ref/default cache msg #f)
     614          (let-optionals* opt ((msg2 #f) (n #f))
     615            (let ((split? (number? n)))
     616              (any
     617               (lambda (gf)
     618                 (and-let* ((x0 (lookup-message gf msg msg2))
     619                            (x (if (and split? (eq? (gfile-type gf) 'mo))
     620                                   (cons (or msg2 msg)
     621                                         (let ((l (string-split x0 null-str)))
     622                                           (map cons (iota (length l)) l)))
     623                                   x0))
     624                            (res (cons x gf)))
     625                   (if cached? (hash-table-set! cache msg res))
     626                   res))
     627               files)))))
    628628
    629629    (define (get msg)
     
    640640        (let ((res (search msg msg2 n)))
    641641          (if (pair? res)
    642             (let ((plural-index (gfile-plural-index (cdr res))))
    643               (or (and (procedure? plural-index)
    644                        (cond
    645                         ((assv (cdar res) (plural-index (or n 1))) => cdr)
    646                         (else #f)))
    647                   (if (eqv? n 1) msg (caar res))))
    648             (if (or (eqv? n 1) (not msg2)) msg msg2)))))
     642              (let ((plural-index (gfile-plural-index (cdr res))))
     643                (or (and (procedure? plural-index)
     644                         (cond
     645                          ((assv (plural-index (or n 1)) (cdar res)) => cdr)
     646                          (else #f)))
     647                    (if (eqv? n 1) msg (caar res))))
     648              (if (or (eqv? n 1) (not msg2)) msg msg2)))))
    649649
    650650    (define (set msg val) (hash-table-set! cache msg val))
  • release/4/free-gettext/trunk/free-gettext.setup

    r24882 r27151  
    77 'free-gettext
    88 '("free-gettext.so" "free-gettext.import.so")
    9  '((version 1.3)))
     9 '((version 1.4)))
Note: See TracChangeset for help on using the changeset viewer.