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 |
|
#:export (format |
8 |
|
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)) |