Re: Dynamically add bindings to the module currently being compiled

;; This solution uses syntax-parameters.

(define-syntax-parameter G_
  ;; G_ is replaced in the body by a call to a function named
  ;; “translate”, which is not defined here.
  (lambda (sintax)
    (syntax-violation 'G_
                      "G_ used outside of with-exported-string-literals"
                      sintax)))

(define-syntax-parameter all-string-literals
  ;; all-string-literals is replaced by the data in the form of a list
  ;; of calls to cons: (cons context-1 message-1) (cons context-2
  ;; message-2). So, the result evaluates to a list of pairs.
  (lambda (sintax)
    (syntax-violation 'all-string-literals
                      "all-string-literals used outside of with-exported-string-literals"
                      sintax)))

(define-syntax with-exported-string-literals
  ;; This big macro will evaluate its guts by replacing calls to G_
  ;; and all-string-literals.
  (lambda (sintax)
    ;; Whenever G_ expands, its arguments are saved in
    ;; collected-strings.
    (define collected-strings '())
    ;; This is a convenience function to push a new collected string
    ;; to the list.
    (define (push-collected-string! context message)
      (unless (string? message)
        (error "only literal string messages are accepted"))
      (unless (or (not context)
                  (string? context))
        (error "only optional literal string contexts are accepted"))
      (set! collected-strings (cons (cons context message)
                                    collected-strings))
      (datum->syntax #f #t))
    ;; The *push-collected-string!* transformer converts calls to a
    ;; G_-like macro by first recording the arguments, and then
    ;; replacing the call with a call to translate.
    (define *push-collected-string!*
      (lambda (sintax)
        (syntax-case sintax ()
          ((_ context-argument message-argument)
           #`(begin
               #,(push-collected-string! (syntax->datum #'context-argument)
                                         (syntax->datum #'message-argument))
               (translate message-argument #:context context-argument)))
          ((_ message-argument)
           #`(begin
               #,(push-collected-string! #f (syntax->datum #'message-argument))
               (translate message-argument))))))
    ;; The *all-collected-string* transformer converts the
    ;; all-string-literals placeholder with code evaluating to the
    ;; data: (list (cons "context-1" "message-1") (cons "context-2"
    ;; "message-2")), because I can’t get the transformer to do (quote
    ;; ("context-1" . "message-1") ...)
    (define *all-collected-strings*
      (lambda (sintax)
        (syntax-case sintax ()
          (_
           #`(list
              #,@(map
                  (lambda (item)
                    #`(cons #,(datum->syntax #f (car item))
                            #,(datum->syntax #f (cdr item))))
                  (reverse collected-strings)))))))
    ;; And now the transformation of the guts to
    ;; with-exported-string-literals.
    (syntax-case sintax ()
      ((_ body ...)
       (with-syntax ((push *push-collected-string!*)
                     (all *all-collected-strings*))
         #'(begin
             ;; It uses syntax-parameterize.
             (syntax-parameterize ((G_ push))
               ;; I can’t end the syntax-parameterize body with the
               ;; dots (wtf???) so I end it with a #t. The body does
               ;; not have access to the all-string-literals form.
               body ... #t)
             (syntax-parameterize ((all-string-literals all))
               (define _i18n:strings
                 all-string-literals)
               (export _i18n:strings))))))))

,expand (with-exported-string-literals
         (define (generic-hello)
           (display (G_ "greeting" "Hello, world!\\n"))
           (newline))
         (define (hello-guile-user)
           (display (G_ "greeting" "Hello, Guile user!\\n"))
           (newline)))

;; Expands to:
#;(begin
  (let ()
    (define (generic-hello)
      (display
        (begin
          #t ;; This is unfortunate but not a problem
          (translate
            "Hello, world!\\n"
            #:context
            "greeting")))
      (newline))
    (define (hello-guile-user)
      (display
        (begin
          #t
          (translate
            "Hello, Guile user!\\n"
            #:context
            "greeting")))
      (newline))
    #t)
  (let ()
    (define _i18n:strings ;; It is unfortunate that I can’t produce a quoted S-expr
      (list (cons "greeting" "Hello, world!\\n")
            (cons "greeting" "Hello, Guile user!\\n")))
    ;; The rest is to export _i18n:strings:
    ((@@ (guile) call-with-deferred-observers)
     (lambda ()
       ((@@ (guile) module-export!)
        ((@@ (guile) current-module))
        '(_i18n:strings))))))