DouKaku?

#include <string.h>

// なにもフォーマットしてない
int mysprintf(char *str, const char *format, ... ){
    strcpy(str, format);
    return strlen(str);
}

(use gauche.sequence)
(use util.match)
(use text.tree)
(use srfi-1)

(define (sprintf fmt . args)
  (define (get-var-arg name v args)
    (if v
      (cond [(string->number v) => (cut values <> args)]
            [(equal? v "*")     (values (car args) (cdr args))]
            [else (error #`",name needs to be a number or '*', but got:" v)])
      (values #f args)))
  (define (pick-arg conv args)
    (if (equal? conv "%") (values #f args) (car+cdr args)))
  (define (rec fmt args)
    (rxmatch-case fmt
      [#/(.*)%([-+ #0]*)(\d+|\*)?(?:\.(\d*|\*))?([diouxXeEfFgGaAcspn%])(.*)/
       (_ before flags width prec conv after)
       (receive (width args) (get-var-arg 'width width args)
         (receive (prec args) (get-var-arg 'prec prec args)
           (receive (arg args) (pick-arg conv args)
             `(,before
               ,(fill width flags (dispatch arg prec flags conv))
               ,(rec after args)))))]
      [else fmt]))
  (define (dispatch arg prec flags conv)
    (case (ref conv 0)
      [(#\d #\i #\u) (int arg prec flags 10 conv)]
      [(#\o)         (int arg prec flags 8 conv)]
      [(#\x #\X)     (int arg prec flags 16 conv)]
      [(#\e #\E #\f #\F #\g #\G) (real arg prec flags conv)]
      [(#\c)         (if (char? arg)
                       (string arg)
                       (error "char required for %c conversion:" arg))]
      [(#\s)         (if (string? arg)
                       (if (and prec (< prec (string-length arg)))
                         (string-take arg prec)
                         arg)
                       (error "string required for %s conversion:" arg))]
      [(#\%)         "%"]
      [else          (error "unsupported conversion:" conv)]))
  (define (fill w f s)
    (or (and-let* ([ w ]
                   [len (string-length s)]
                   [(< len w)]
                   [pad (- w len)])
          (if (string-index f #\-)
            (cons s (make-string pad #\space))
            (cons (make-string pad (if (string-index f #\0) #\0 #\space)) s)))
        s))
  (define (sign arg f s)
    (define (pos-sign)
      (cond [(string-index f #\+) "+"]
            [(string-index f #\space) " "]
            [else ""]))
    (string-append (if (negative? arg) "-" (pos-sign)) s))
  (define (minpad p s)
    (if (and p (< (string-length s) p))
      (string-append (make-string (- p (string-length s)) #\0) s)
      s))
  (define (prefix f c s)
    (if (string-index f #\#)
      (case (ref c 0)
        [(#\o) (string-append "0" s)]

        [(#\x) (string-append "0x" s)]
        [(#\X) (string-append "0X" s)])
      s))
  (define (int arg p f r c)
    (unless (and (exact? arg) (integer? arg))
      (error "exact integer required for conversion:" c))
    (sign arg f (prefix f c (minpad p (number->string (abs arg) r (equal? c "X"))))))
  (define (maxprec p s)
    (cond [(not p) s]
          [else
           (regexp-replace*
            s #/\.(\d+)/
            (lambda (m)
              (cond [(zero? p) ""]
                    [else
                     (let1 oprec (string-length (m 1))
                       (cond [(< p oprec)
                              #`".,(round->exact (/. (string->number (m 1)) (expt 10 (- oprec p))))"]
                             [else
                              #`".,(m 1),(make-string (- p oprec) #\\0)"]))
                     ])))
           ]))
  (define (real arg p f c)
    (unless (real? arg)
      (error "real number required for conversion:" c))
    (maxprec p (number->string arg)))
  (tree->string (rec fmt args)))

;;; nt/printf.scm
(define-module nt.printf
  (export
   printf
   sprintf
   ))

(select-module nt.printf)

(define (log10 x) (/ (log x) (log 10.0)))

(define (sprintf fmt . args)
  (let ((out (open-output-string)))
    (let loop ((fmt fmt) (args args))
      (define (ret) (display fmt out) (get-output-string out))
      (let ((match (#/%(?<flag>[-+# 0]*)(?<num>[1-9][0-9]*)?(\.(?<below>[0-9]+))?(?<type>[%diouxXfeEgGbcs])/ fmt)))
        (if match
            (let* ((flags (if (match 'flag) (string->list (match 'flag)) '()))
                   (num (match 'num)) ;str/指定がなければ#f. ※0.8.11までは#fではなく""が返る
                   (below (match 'below)) ;str/指定がなければ#f. ※0.8.11までは#fではなく""が返る
                   (type (string->symbol (match 'type)))
                   (consumes-an-arg? (not (eq? '% type)))
                   (flush-left? (memq #\- flags))
                   (signed? (memq #\+ flags))
                   (zero-pad? (memq #\0 flags))
                   )
              (if (and consumes-an-arg? (null? args))
                  (ret) ;;; arguments-exhausted
                  (let ((arg (if consumes-an-arg? (car args) 'not-eaten)))
                    
                    (define (format-int-value type)
                      (let ((%value (if (integer? arg) arg (x->integer (truncate (x->number arg))))))
                        (if flush-left?
                            (let ((%fmt (string-append "~" type)))
                              (format (string-append "~" (or num "") "a") (format %fmt %value)))
                            (let ((%fmt (string-append "~" (or num "") "," (if zero-pad? "'0" "")
                                                       (if signed? "@" "") type)))
                              (format %fmt %value)))))

                    (define (format-float-value); type)
                      (let* ((%value (if (real? arg) arg (x->number arg)))
                             (%e-offset (x->integer (floor (log10 (abs %value)))))
                             (%precision (case type
                                           ((f)
;                                            (if (string=? "" below) 6 (x->integer below))) ; < 0.8.12
                                            (if below (x->integer below) 6))
                                           ((e E)
                                            (cond ((> %e-offset 0) ;;; sorry i'm using (set!)
                                                   (set! %value (/ %value (expt 10 %e-offset))))
                                                  ((< %e-offset 0)
                                                   (set! %value (* %value (expt 10 (abs %e-offset)))))
                                                  (else #t))
;                                            (if (string=? "" below) 6 (x->integer below))) ;< 0.8.12
                                            (if below (x->integer below) 6))
;                                           (else (if (string=? "" below) 12 (x->integer below))))) ;< 0.8.12
                                           (else (if below (x->integer below) 12))))
                             )
                        (let* ((%int (x->integer (if (= 0 %precision)
                                                     (round %value)
                                                     (truncate %value))))
                               (%fract (abs (- %value %int)))
                               (%rounded (x->integer (round (+ (expt 0.1 (+ %precision 1))
                                                               (* (expt 10 %precision) %fract)))))
                               (%str (if (= 0 %precision)
                                         (format "~d" %int)
                                         (format (string-append "~d.~" (format "~d" %precision) ",'0d")
                                                 %int %rounded)))
                               (%f-fmt (string-append "~" (or num "") ;"," (if zero-pad? "'0" "")
                                                      (if flush-left? "" "@") "a"))
                               (%e-fmt (string-append %f-fmt
                                                      "~a" ; [eE]
                                                      (if (< %e-offset 0) "-" "+")
                                                      "~2,'0d"))
                               )
                          (case type
                            ((f)
                             (format %f-fmt %str))
                            ((g G)
                             (format %f-fmt (regexp-replace #/0+$/ %str "")))
                            ((e E)
                             (format %e-fmt %str type (abs %e-offset))
                             )
                            ))))
                    
                    (display (match 'before) out)
                    ;; warnings
;                    (case type
;                      ((d i)
;                       (when (not (integer? arg))
;                             (print "warning: %~a requires <integer>" type) ))
;                      ((b o u X x c)
;                       (when (not (and (integer? arg) (< 0 arg)))
;                             (print "warning: %~a requires <unsigned integer>" type) ))
;                      ((f e E g G)
;                       (when (not (real? arg))
;                             (print "warning: %~a requires <real>" type)))
;;                      ((b)) ; we use %b for unsigned binary
;                      ((s)
;                       (when (not (string? arg))
;                             (format "warning: %s requires <string>")))
;                      )
                    (display (case type
                               ((d o x X) ;;  %bを２進表記に使いたい場合は (d b o x X)
                                (format-int-value (match 'type)))
                               ((i u) ; signed/unsigned decimal
                                (format-int-value "d"))
                               ((f) ;float ; [-]ddd.ddd
                                (format-float-value))
                               ((e E) ;'not-supported) ; [-]d.ddde+-dd
                                (format-float-value))
                               ((g G) ; 'not-supported) ;
                                (format-float-value))
;                               ((b) 'not-supported) ; backslash-escape seq
                               ((c) ; first-char
                                (cond ((integer? arg)
                                       (string (integer->char arg)))
                                      ((string? arg)
                                       (string-ref arg 0))
                                      (else 
                                       (string (integer->char (truncate (x->number arg))))) ))
                               ((s) ; 'str
                                (let1 %s-fmt (string-append "~"
                                                            (format "~a~a"
                                                                    (or num "")
                                                                    (if flush-left? "" "@")
                                                                    )
                                                            "a")
                                      (format %s-fmt arg)))
                               ((%) "%")) out)
                    (loop (match 'after)
                          (if consumes-an-arg? (cdr args) args))
                    )))
            (ret))))))

(define (printf fmt . args) (display (apply sprintf (cons fmt args))))

(provide "nt/printf")
;;EOF