home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / lang / elisp / internals / format.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  1.8 KB  |  63 lines
  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))
  63.