guile18/lang/elisp/internals/format.scm

   1 (define-module (lang elisp internals format)
   2   #:pure
   3   #:use-module (ice-9 r5rs)
   4   #:use-module ((ice-9 format) #:select ((format . scheme:format)))
   5   #:use-module (lang elisp internals fset)
   6   #:use-module (lang elisp internals signal)
   7   #:replace (format)
   8   #:export (message))
   9
  10 (define (format control-string . args)
  11
  12   (define (cons-string str ls)
  13     (let loop ((sl (string->list str))
  14                (ls ls))
  15       (if (null? sl)
  16           ls
  17           (loop (cdr sl) (cons (car sl) ls)))))
  18
  19   (let loop ((input (string->list control-string))
  20              (args args)
  21              (output '())
  22              (mid-control #f))
  23     (if (null? input)
  24         (if mid-control
  25             (error "Format string ends in middle of format specifier")
  26             (list->string (reverse output)))
  27         (if mid-control
  28             (case (car input)
  29               ((#\%)
  30                (loop (cdr input)
  31                      args
  32                      (cons #\% output)
  33                      #f))
  34               (else
  35                (loop (cdr input)
  36                      (cdr args)
  37                      (cons-string (case (car input)
  38                                     ((#\s) (scheme:format #f "~A" (car args)))
  39                                     ((#\d) (number->string (car args)))
  40                                     ((#\o) (number->string (car args) 8))
  41                                     ((#\x) (number->string (car args) 16))
  42                                     ((#\e) (number->string (car args))) ;FIXME
  43                                     ((#\f) (number->string (car args))) ;FIXME
  44                                     ((#\g) (number->string (car args))) ;FIXME
  45                                     ((#\c) (let ((a (car args)))
  46                                              (if (char? a)
  47                                                  (string a)
  48                                                  (string (integer->char a)))))
  49                                     ((#\S) (scheme:format #f "~S" (car args)))
  50                                     (else
  51                                      (error "Invalid format operation %%%c" (car input))))
  52                                   output)
  53                      #f)))
  54             (case (car input)
  55               ((#\%)
  56                (loop (cdr input) args output #t))
  57               (else
  58                (loop (cdr input) args (cons (car input) output) #f)))))))
  59
  60 (define (message control-string . args)
  61   (display (apply format control-string args))
  62   (newline))