;; gettext.scm -- gettext superset implemented in Scheme
;;
;; Copyright (c) 2003-2012 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;; Modifications for CHICKEN 4 by Thomas Chust (2010)



;; This is *not* gettext, nor does it use the C gettext library.
;;
;; This is a full gettext superset written in pure Scheme from reading
;; the gettext documentation - I have never looked at the gettext source
;; code, so this may be used under a more liberal BSD-style license as
;; above.
;;
................................................................................
;; build these closures manually for convenience in using multiple
;; separate domains or locales at once (useful for server environments):
;;
;;  (define my-gettext (make-gettext "myapp"))
;;  (define _ (my-gettext 'getter))
;;  (_"Hello, World!")

(require-library
 extras data-structures regex ports files posix
 srfi-1 srfi-13 srfi-69
 charconv)

(module free-gettext

  (;; standard gettext interface
   gettext textdomain dgettext dcgettext bindtextdomain
   ngettext dngettext dcngettext
   ;; the parameter for the standard interface
   default-gettext-lookup
   ;; more flexible interface for building lookups
   make-gettext
   ;; gfile accessors
   gfile? gfile-filename gfile-locale gfile-encoding
   gfile-properties gfile-type gfile-plural-index
   make-gettext-file
   ;; low-level parsers
   lookup-po-message lookup-mo-message)
  (import
   scheme chicken extras data-structures regex ports files posix
   srfi-1 srfi-13 srfi-69











   charconv)























































;; ^^^ Non-SRFI imports:
;;
;; WITH-INPUT-FROM-ENCODED-FILE, CES-CONVERT and DETECT-FILE-ENCODING
;;   from charconv (Gauche compatible API)
;; GET-ENVIRONMENT-VARIABLE and FILE-READ-ACCESS? from posix
;; RFC822-HEADER->LIST from mime (port from Gauche)
;; LET-OPTIONALS* from Shivers' SRFIs
................................................................................
      (append-map
       (lambda (x)
         (map (lambda (sub-prod) (cons x sub-prod)) rest))
       l))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mime utils (from hato)

(define (rfc822-read-headers in)
  (let more ([line (read-line in)])
    (cond
     ((or (eof-object? line) (string-null? line))
      '())
     ((let ([cont (peek-char in)])
	(and (not (memv cont '(#\return #\newline #!eof)))
	     (char-whitespace? cont)))
      (more (string-append line (read-line in))))
     ((string-match "(.*?)\\s*:\\s*(.*)" line)
      => (lambda (match)
	   (cons (cons (string-downcase! (string-trim (cadr match)))
		       (cddr match))
		 (rfc822-read-headers in))))
     (else
      (rfc822-read-headers in)))))

(define (mime-split-name+value s)
  (let ((i (string-index s #\=)))
................................................................................

(define (mime-parse-content-type str)
  (map mime-split-name+value (string-split str ";")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; binary I/O utils (from SRFI-56)

(define (read-binary-uint32-le . o)
  (let* ((in (if (pair? o) (car o) (current-input-port)))
         (b1 (read-byte in))
         (b2 (read-byte in))
         (b3 (read-byte in))
         (b4 (read-byte in)))
    (if (eof-object? b4)
        b4
        (+ (arithmetic-shift b4 24)
           (arithmetic-shift b3 16)
           (arithmetic-shift b2 8)
           b1))))

(define (read-binary-uint32-be . o)
  (let* ((in (if (pair? o) (car o) (current-input-port)))
         (b1 (read-byte in))
         (b2 (read-byte in))
         (b3 (read-byte in))
         (b4 (read-byte in)))
    (if (eof-object? b4)
        b4
        (+ (arithmetic-shift b1 24)
           (arithmetic-shift b2 16)
           (arithmetic-shift b3 8)
           b4))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Customize this to the appropriate value for your system:

(define message-path (list (make-pathname (repository-path) "locale")))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; store meta info for gettext files

(define-record-type gfile
  (%make-gfile filename locale encoding properties type plural-index)
  gfile?
  (filename gfile-filename)  ;; these are all immutable
  (locale gfile-locale)
  (encoding gfile-encoding)
  (properties gfile-properties)
  (type gfile-type)
  (plural-index gfile-plural-index)
  )

(define (make-gettext-file filename locale)
  (let* ((file-type (if (string-suffix? ".mo" filename) 'mo 'po))
         (property-msg (lookup-message filename "" "utf8"))
         (properties (if property-msg
                         (call-with-input-string property-msg
                           rfc822-read-headers)
................................................................................
                         '()))
         (content-type
          (mime-parse-content-type
           (cond ((assoc "content-type" properties) => cadr)
                 (else ""))))
         (encoding
          (cond ((assoc "charset" content-type) => cdr)
                (else (or (detect-file-encoding filename locale) "utf8"))))
         (plural-index
          (cond
            ((assoc "plural-forms" properties)
             => (lambda (x)
                  (cond
                    ((assoc "plural" (mime-parse-content-type (cadr x)))
                     => (lambda (x) (C->Scheme (cdr x))))
................................................................................
           (cons n (read-str str)))
         => (lambda (x) (reader (cons x res))))
        (else (reverse res)))))

  ;; read from the file if it exists
  (and
   (file-read-access? file)
   (condition-case



       (with-input-from-encoded-file file encoding

         (lambda ()
           (let search ((line (read-line)))
             (cond ((eof-object? line) #f)
                   ((string-prefix? "msgid " line)
                    (let ((msgid (read-str (tail-str line))))
                      (cond ((string=? msgid msg)
                             (let lp ((line (read-line)))
                               (cond ((eof-object? line) #f)
                                     ((string-prefix? "msgid_plural " line)
                                      (read-plural (read-str (tail-str line))))
                                     ((string-prefix? "msgstr " line)
                                      (read-str (tail-str line)))
                                     (else (lp (read-line))))))
                            (else (search (read-line))))))
                   (else (search (read-line)))))))
     (exn ()
          (print-error-message exn (current-error-port)
                               "Warning: lookup-po-message")
          ;;(print-call-chain (current-error-port))
          #f))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The gettext binary .mo file parser.
;;   The format is well described in the GNU gettext documentation.
;;   Essentially it's an index of source strings with offsets to their
;;   translation string, and we binary search the index.

(define (lookup-mo-message file msg msg2 encoding)
  (and
   (file-read-access? file)
   (condition-case
       (with-input-from-file file



         (lambda ()

           (define (search read-int)
             (let* ((key (if msg2 (string-append msg null-str msg2) msg))
                    (format (read-int))
                    (count (read-int))
                    (src-offset (read-int))
                    (trans-offset (read-int))
                    (hash-size (read-int))
                    (hash-offset (read-int))
                    (diff (- trans-offset src-offset))
                    (end (+ src-offset (* (- count 1) 8))))
               (define (string-at pos)
                 (set-file-position! (current-input-port) pos)
                 (let* ((len (read-int))
                        (off (read-int)))
                   (set-file-position! (current-input-port) off)
                   (ces-convert (read-string len) encoding)))

               (cond ;; check endpoints
                 ((string=? key (string-at src-offset))
                  (string-at (+ src-offset diff)))
                 ((and (> end src-offset) (string=? key (string-at end)))
                  (string-at (+ end diff)))
                 (else ;; binary search
                  (let loop ((lo 0) (hi (- count 1)))
                    (if (>= lo hi)
                        #f
                        (let* ((mid (+ lo (quotient (- hi lo) 2)))
                               (pos (+ src-offset (* mid 8)))
                               (str (string-at pos)))
                          (cond
                            ((string<? key str)
                             (if (>= mid hi) #f (loop lo mid)))
                            ((string>? key str)
                             (if (<= mid lo) #f (loop mid hi)))
                            (else ;; match
                             (string-at (+ pos diff)))))))))))
           (let* ((b1 (read-byte))
                  (b2 (read-byte))
                  (b3 (read-byte))
                  (b4 (read-byte))
                  (magic (list b1 b2 b3 b4)))
             (cond
               ((equal? magic '(#xde #x12 #x04 #x95))
                (search read-binary-uint32-le))
               ((equal? magic '(#x95 #x04 #x12 #xde))
                (search read-binary-uint32-be))
               (else
                (warning "invalid .mo file magic" magic)
                #f)))))
     (exn ()
          (print-error-message exn (current-error-port)
                               "Warning: lookup-mo-message")
          ;;(print-call-chain (current-error-port))
          #f))))

(define (lookup-message gfile msg msg2 . opt)
  (if (gfile? gfile)
      ((if (eq? (gfile-type gfile) 'mo) lookup-mo-message lookup-po-message)
       (gfile-filename gfile)
       msg
       msg2
................................................................................
            ((#\|) (if (eqv? (peek-char) c) (begin (read-char) 'or) 'logior))
            ((#\! #\> #\<)
             (cond ((eqv? (peek-char) #\=)
                    (read-char) (string->symbol (string c #\=)))
                   (else (string->symbol (string c)))))
            ((#\=)
             (cond ((eqv? (peek-char) #\=) (read-char) '==)
                   (else (warning "invalid assignment in C code") #f)))
            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
             (read-number c))
            ((#\n) 'n)
            ((#\space #\newline) (next-token))
            (else (warning "invalid character in C code: ~S" c) #f)))))
  (define (C-parse str)
    (define (precedence x) ;; lower value is higher precedence
      (case x
        ((**) 10)           ((&) 70)
        ((! ~) 20)          ((^ logand logior) 80)
        ((* / %) 30)        ((and) 90)
        ((+ -) 40)          ((or) 100)
................................................................................
              ((eq? x 'open) (parse-until 'close))
              ((memq x '(! ~)) `(,x ,(parse1)))
              (else x))))
    (define (parse-until end)
      (define (group op left right)
        (cond
         ((or (eq? right end) (eq? right 'eof))
          (warning "expected 2nd argument to" op)
          `(op ,left))
         ((eq? op 'and)
          `(if (zero? ,left) 0 ,right))
         ((eq? op 'or)
          `(if (zero? ,left) ,right 1))
         (else
          `(,op ,left ,right))))
................................................................................
      (let ((init (parse1)))
        (if (equal? init end)
            '()
            (let parse ((left init) (op (parse1)) (stack '()))
              (cond
               ((eq? op end) (join left stack))
               ((eq? op 'eof)
                (warning "unexpected #<eof>")
                (join left stack))
               ((eq? op '?) ;; trinary ? : (right-assoc)
                (let* ((pass (parse-until ':))
                       (fail (parse1))
                       (op2 (parse1)))
                  (cond
                   ((or (eq? op2 end) (eq? op2 'eof))
................................................................................
(define (make-gettext-internal domain locale dirs cdir cached?)

  (define (make-cache) (make-hash-table))

  (define (make-file-list)
    (define suffixes '(".mo" ".po"))
    (reverse
     (fold
      (lambda (x res)
        (let ((path
               (string-append
                (caddr x) "/" (car x) "/" cdir "/" (cadr x) (cadddr x))))
          (if (file-read-access? path)
              (cons (make-gettext-file path (car x)) res)
              res)))
................................................................................
                               dirs
                               suffixes)))))

  (let ((files (make-file-list))
        (cache (make-cache)))

    (define (search msg . opt)
      (if (and cached? (hash-table-exists? cache msg))
          (hash-table-ref/default cache msg #f)
          (let-optionals* opt ((msg2 #f) (n #f))
            (let ((split? (number? n)))
              (any
               (lambda (gf)
                 (and-let* ((x0 (lookup-message gf msg msg2))
                            (x (if (and split? (eq? (gfile-type gf) 'mo))
................................................................................
                       (or dirs0 (cond ((get-environment-variable "GETTEXT_PATH")
                                        => (cut string-split <> ":"))
                                       (else '())))))
               ;; prepend default dirs based on domain
               (dirs (append (hash-table-ref/default
                              domain-message-paths
                              domain
                              message-path)
                             dirs1))
               (cdir (or cdir0
                         (get-environment-variable "LC_CATEGORY")
                         "LC_MESSAGES")))
          ;; optionally lookup from cache
          (if lookup-cached?
            (let* ((key (list domain locale dirs cdir gettext-cached?))

;; gettext.scm -- gettext superset implemented in Scheme
;;
;; Copyright (c) 2003-2012 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;; Modifications for CHICKEN 4 by Thomas Chust (2010)
;;
;; Modifications for Chez Scheme by Aldo Nicolas Bruno (2016)
;;
;; This is *not* gettext, nor does it use the C gettext library.
;;
;; This is a full gettext superset written in pure Scheme from reading
;; the gettext documentation - I have never looked at the gettext source
;; code, so this may be used under a more liberal BSD-style license as
;; above.
;;
................................................................................
;; build these closures manually for convenience in using multiple
;; separate domains or locales at once (useful for server environments):
;;
;;  (define my-gettext (make-gettext "myapp"))
;;  (define _ (my-gettext 'getter))
;;  (_"Hello, World!")






(library (free-gettext)
  (export
   ;; standard gettext interface
   gettext textdomain dgettext dcgettext bindtextdomain
   ngettext dngettext dcngettext
   ;; the parameter for the standard interface
   default-gettext-lookup
   ;; more flexible interface for building lookups
   make-gettext
   ;; gfile accessors
   gfile? gfile-filename gfile-locale gfile-encoding
   gfile-properties gfile-type gfile-plural-index
   make-gettext-file
   ;; low-level parsers
   lookup-po-message lookup-mo-message)
  (import (chezscheme)
	  (data-structures)
	  (irregex)
	  (srfi s2 and-let)
	  (srfi private let-opt)
	  (srfi s26 cut)
	  (only (srfi s1 lists) append-map any)
	  (only (srfi s13 strings) string-trim string-trim-both
		substring/shared string-index string-suffix? string-prefix?
		string-concatenate-reverse)
	  (only (thunder-utils) string-split read-string))

  ;; implement string-match with irregex
  (define (string-match regex txt)
    (cond
     [(irregex-match (irregex regex) txt)
      => (lambda (m)
	   (map (lambda (x)
		  (irregex-match-substring m x))
		(iota (+ 1 (irregex-match-num-submatches m)))))]
     [else #f]))
  (alias get-environment-variable getenv)
  (alias arithmetic-shift bitwise-arithmetic-shift)
  (alias hash-table-ref/default hashtable-ref)
  (alias hash-table-set! hashtable-set!)
  (alias hashtable-exists? hashtable-contains?)
  
  (define read-byte
    (case-lambda
     [() (get-u8 (current-input-port))]
     [(p) (get-u8 p)]))
  (define read-line (case-lambda
		     [() (get-line (current-input-port))]
		     [(port) (get-line port)]))
  (define (string-null? x) (string=? x ""))
  
  (define (call-with-input-string str proc)
    (with-input-from-string str
      (proc (current-input-port))))
  
  (define (select-transcoder enc)
    (make-transcoder
		   (cond [(or (not enc) (string-ci=? enc "utf8") (string-ci=? enc "utf-8"))
			  (utf-8-codec)]
			 [(string-ci=? enc "latin1")
			  (latin-1-codec)]
			 [else
			  (iconv-codec enc)])))

  (define (with-input-from-encoded-file file enc thunk)
    (call-with-port
     (transcoded-port (open-input-file file) (select-transcoder enc))
     (lambda (port)
       (parameterize ([current-input-port port]) (thunk)))))
  
  (define (file-read-access? path)
    (cond
     [(guard (e [else #f]) (open-file-input-port path ))
      => (lambda (p)
	   (close-port p)
	   #t)]
     [else
      #f]))
    
  (define (make-pathname . l)
    (string-intersperse l (string (directory-separator))))

  (define (print-error-message cond port desc)
    (display desc port) (display-condition cond port) )
  
;; ^^^ Non-SRFI imports:
;;
;; WITH-INPUT-FROM-ENCODED-FILE, CES-CONVERT and DETECT-FILE-ENCODING
;;   from charconv (Gauche compatible API)
;; GET-ENVIRONMENT-VARIABLE and FILE-READ-ACCESS? from posix
;; RFC822-HEADER->LIST from mime (port from Gauche)
;; LET-OPTIONALS* from Shivers' SRFIs
................................................................................
      (append-map
       (lambda (x)
         (map (lambda (sub-prod) (cons x sub-prod)) rest))
       l))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mime utils (from hato)

(define (rfc822-read-headers in)
  (let more ([line (read-line in)])
    (cond
     ((or (eof-object? line) (string-null? line))
      '())
     ((let ([cont (peek-char in)])
	(and (not (or (eof-object? cont) (memv cont '(#\return #\newline))))
	     (char-whitespace? cont)))
      (more (string-append line (read-line in))))
     ((string-match "(.*?)\\s*:\\s*(.*)" line)
      => (lambda (match)
	   (cons (cons (string-downcase (string-trim (cadr match)))
		       (cddr match))
		 (rfc822-read-headers in))))
     (else
      (rfc822-read-headers in)))))

(define (mime-split-name+value s)
  (let ((i (string-index s #\=)))
................................................................................

(define (mime-parse-content-type str)
  (map mime-split-name+value (string-split str ";")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; binary I/O utils (from SRFI-56)

(define (read-binary-uint32-le in)

  (let* ((b1 (read-byte in))
         (b2 (read-byte in))
         (b3 (read-byte in))
         (b4 (read-byte in)))
    (if (eof-object? b4)
        b4
        (+ (arithmetic-shift b4 24)
           (arithmetic-shift b3 16)
           (arithmetic-shift b2 8)
           b1))))

(define (read-binary-uint32-be in)

  (let* ((b1 (read-byte in))
         (b2 (read-byte in))
         (b3 (read-byte in))
         (b4 (read-byte in)))
    (if (eof-object? b4)
        b4
        (+ (arithmetic-shift b1 24)
           (arithmetic-shift b2 16)
           (arithmetic-shift b3 8)
           b4))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Customize this to the appropriate value for your system:

;(define message-path (list (make-pathname (repository-path) "locale")))

(define message-path (make-parameter (list "/usr/share/locale")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; store meta info for gettext files

(define-record-type (gfile %make-gfile gfile?)
  (fields

   (immutable filename gfile-filename)
   (immutable locale gfile-locale)
   (immutable encoding gfile-encoding)
   (immutable properties gfile-properties)
   (immutable type gfile-type)
   (immutable plural-index gfile-plural-index)))


(define (make-gettext-file filename locale)
  (let* ((file-type (if (string-suffix? ".mo" filename) 'mo 'po))
         (property-msg (lookup-message filename "" "utf8"))
         (properties (if property-msg
                         (call-with-input-string property-msg
                           rfc822-read-headers)
................................................................................
                         '()))
         (content-type
          (mime-parse-content-type
           (cond ((assoc "content-type" properties) => cadr)
                 (else ""))))
         (encoding
          (cond ((assoc "charset" content-type) => cdr)
                (else "utf8")))
         (plural-index
          (cond
            ((assoc "plural-forms" properties)
             => (lambda (x)
                  (cond
                    ((assoc "plural" (mime-parse-content-type (cadr x)))
                     => (lambda (x) (C->Scheme (cdr x))))
................................................................................
           (cons n (read-str str)))
         => (lambda (x) (reader (cons x res))))
        (else (reverse res)))))

  ;; read from the file if it exists
  (and
   (file-read-access? file)
   (guard
    (exn [else (print-error-message exn (current-error-port)
				    "Warning: lookup-po-message" )
	       #f])
    (with-input-from-encoded-file
     file encoding
     (lambda ()
       (let search ((line (read-line)))
	 (cond ((eof-object? line) #f)
	       ((string-prefix? "msgid " line)
		(let ((msgid (read-str (tail-str line))))
		  (cond ((string=? msgid msg)
			 (let lp ((line (read-line)))
			   (cond ((eof-object? line) #f)
				 ((string-prefix? "msgid_plural " line)
				  (read-plural (read-str (tail-str line))))
				 ((string-prefix? "msgstr " line)
				  (read-str (tail-str line)))
				 (else (lp (read-line))))))
			(else (search (read-line))))))
	       (else (search (read-line))))))))))







;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The gettext binary .mo file parser.
;;   The format is well described in the GNU gettext documentation.
;;   Essentially it's an index of source strings with offsets to their
;;   translation string, and we binary search the index.

(define (lookup-mo-message file msg msg2 encoding)
  (and
   (file-read-access? file)
   (guard
    (exn [else (print-error-message exn (current-error-port)
				    "Warning: lookup-mo-message")
	       #f])
    (call-with-port (open-file-input-port file) ;; open in binary mode
		    (lambda (p)
		      (define tc (select-transcoder encoding))
		      (define (search read-int)
			 (let* ((key (if msg2 (string-append msg null-str msg2) msg))
				(format (read-int p))
				(count (read-int p))
				(src-offset (read-int p))
				(trans-offset (read-int p))
				(hash-size (read-int p))
				(hash-offset (read-int p))
				(diff (- trans-offset src-offset))
				(end (+ src-offset (* (- count 1) 8))))
			   (define (string-at pos)
			     (file-position p pos)
			     (let* ((len (read-int p))
				    (off (read-int p)))
			       (file-position p off)

			       (bytevector->string (get-bytevector-n p len) tc)))
			   (cond ;; check endpoints
			    ((string=? key (string-at src-offset))
			     (string-at (+ src-offset diff)))
			    ((and (> end src-offset) (string=? key (string-at end)))
			     (string-at (+ end diff)))
			    (else ;; binary search
			     (let loop ((lo 0) (hi (- count 1)))
			       (if (>= lo hi)
				   #f
				   (let* ((mid (+ lo (quotient (- hi lo) 2)))
					  (pos (+ src-offset (* mid 8)))
					  (str (string-at pos)))
				     (cond
				      ((string<? key str)
				       (if (>= mid hi) #f (loop lo mid)))
				      ((string>? key str)
				       (if (<= mid lo) #f (loop mid hi)))
				      (else ;; match
				       (string-at (+ pos diff)))))))))))
		       (let* ((b1 (read-byte p))
			      (b2 (read-byte p))
			      (b3 (read-byte p))
			      (b4 (read-byte p))
			      (magic (list b1 b2 b3 b4)))
			 (cond
			  ((equal? magic '(#xde #x12 #x04 #x95))
			   (search read-binary-uint32-le))
			  ((equal? magic '(#x95 #x04 #x12 #xde))
			   (search read-binary-uint32-be))
			  (else
			   (warning "invalid .mo file magic" magic)
			   #f))))))))






(define (lookup-message gfile msg msg2 . opt)
  (if (gfile? gfile)
      ((if (eq? (gfile-type gfile) 'mo) lookup-mo-message lookup-po-message)
       (gfile-filename gfile)
       msg
       msg2
................................................................................
            ((#\|) (if (eqv? (peek-char) c) (begin (read-char) 'or) 'logior))
            ((#\! #\> #\<)
             (cond ((eqv? (peek-char) #\=)
                    (read-char) (string->symbol (string c #\=)))
                   (else (string->symbol (string c)))))
            ((#\=)
             (cond ((eqv? (peek-char) #\=) (read-char) '==)
                   (else (warning 'C->Scheme:next-token "invalid assignment in C code") #f)))
            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
             (read-number c))
            ((#\n) 'n)
            ((#\space #\newline) (next-token))
            (else (warning 'C->Scheme:next-token "invalid character in C code: ~S" c) #f)))))
  (define (C-parse str)
    (define (precedence x) ;; lower value is higher precedence
      (case x
        ((**) 10)           ((&) 70)
        ((! ~) 20)          ((^ logand logior) 80)
        ((* / %) 30)        ((and) 90)
        ((+ -) 40)          ((or) 100)
................................................................................
              ((eq? x 'open) (parse-until 'close))
              ((memq x '(! ~)) `(,x ,(parse1)))
              (else x))))
    (define (parse-until end)
      (define (group op left right)
        (cond
         ((or (eq? right end) (eq? right 'eof))
          (warning 'C-parse "expected 2nd argument to" op)
          `(op ,left))
         ((eq? op 'and)
          `(if (zero? ,left) 0 ,right))
         ((eq? op 'or)
          `(if (zero? ,left) ,right 1))
         (else
          `(,op ,left ,right))))
................................................................................
      (let ((init (parse1)))
        (if (equal? init end)
            '()
            (let parse ((left init) (op (parse1)) (stack '()))
              (cond
               ((eq? op end) (join left stack))
               ((eq? op 'eof)
                (warning 'C-parse:parse-until "unexpected #<eof>")
                (join left stack))
               ((eq? op '?) ;; trinary ? : (right-assoc)
                (let* ((pass (parse-until ':))
                       (fail (parse1))
                       (op2 (parse1)))
                  (cond
                   ((or (eq? op2 end) (eq? op2 'eof))
................................................................................
(define (make-gettext-internal domain locale dirs cdir cached?)

  (define (make-cache) (make-hash-table))

  (define (make-file-list)
    (define suffixes '(".mo" ".po"))
    (reverse
     (fold-right
      (lambda (x res)
        (let ((path
               (string-append
                (caddr x) "/" (car x) "/" cdir "/" (cadr x) (cadddr x))))
          (if (file-read-access? path)
              (cons (make-gettext-file path (car x)) res)
              res)))
................................................................................
                               dirs
                               suffixes)))))

  (let ((files (make-file-list))
        (cache (make-cache)))

    (define (search msg . opt)
      (if (and cached? (hashtable-exists? cache msg))
          (hash-table-ref/default cache msg #f)
          (let-optionals* opt ((msg2 #f) (n #f))
            (let ((split? (number? n)))
              (any
               (lambda (gf)
                 (and-let* ((x0 (lookup-message gf msg msg2))
                            (x (if (and split? (eq? (gfile-type gf) 'mo))
................................................................................
                       (or dirs0 (cond ((get-environment-variable "GETTEXT_PATH")
                                        => (cut string-split <> ":"))
                                       (else '())))))
               ;; prepend default dirs based on domain
               (dirs (append (hash-table-ref/default
                              domain-message-paths
                              domain
                              (message-path))
                             dirs1))
               (cdir (or cdir0
                         (get-environment-variable "LC_CATEGORY")
                         "LC_MESSAGES")))
          ;; optionally lookup from cache
          (if lookup-cached?
            (let* ((key (list domain locale dirs cdir gettext-cached?))