WiLiKiソース解読:src/extract.scm

 (define (scan-src file)
  (define msgs '())
  (define (rec expr)
    (when (pair? expr)
      (if (and (eq? (car expr) '$$)
               (pair? (cdr expr))
               (null? (cddr expr))
               (string? (cadr expr)))
          (push! msgs
                 `(,(cadr expr) ,(pair-attribute-get expr 'source-info #f) ""))
          (for-each rec expr))))
  (rec (call-with-input-file file port->sexp-list))
  msgs)

 (define (scan-msgfile file)
  (if (file-exists? file)
      (call-with-input-file file port->sexp-list)
      '()))

 (define (multiline-string str)
  (string-append
   "\""
   (string-join
    (map (cut regexp-replace-all #/[\"\\]/ <> (lambda (m) #`"\\,(m 0)"))
         (string-split str #\newline))
    "\n")
   "\""))

 (define (main args)
  (unless (= (length args) 3)
    (error "usage: gosh extract.scm file.scm msg-file"))
  (let* ((src-file (cadr args))
         (dst-file (caddr args))
         (dst-tmp  (string-append dst-file ".t"))
         (src-msgs (scan-src src-file))
         (dst-msgs (scan-msgfile dst-file)))
    (for-each (lambda (dst-msg)
                (cond ((assoc (car dst-msg) src-msgs)
                       => (lambda (p)
                            (set! (caddr p) (cadr dst-msg))
                            (set! (cddr dst-msg) #t)))))
              dst-msgs)
    (call-with-output-file (string-append dst-file ".t")
      (lambda (p)
        (for-each (lambda (src-msg)
                    (apply format p ";; ~a : line ~a\n" (cadr src-msg))
                    (format p "(~a\n" (multiline-string (car src-msg)))
                    (format p " ~a\n" (multiline-string (caddr src-msg)))
                    (format p ")\n\n"))
                  (reverse src-msgs))
        (for-each (lambda (dst-msg)
                    (when (null? (cddr dst-msg))
                      (format p "#| obsoleted message\n")
                      (format p "~a\n" (multiline-string (car dst-msg)))
                      (format p "~a\n|#\n" (multiline-string (cadr dst-msg)))))
                  (reverse dst-msgs))))
    (when (file-exists? dst-file)
      (sys-rename dst-file (string-append dst-file ".orig")))
    (sys-rename dst-tmp dst-file))
  0)