Commit | Line | Data |
---|---|---|
d3cf93bc | 1 | /* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc. |
eb46d7af | 2 | * |
d3cf93bc NJ |
3 | * This library is free software; you can redistribute it and/or |
4 | * modify it under the terms of the GNU Lesser General Public | |
5 | * License as published by the Free Software Foundation; either | |
6 | * version 2.1 of the License, or (at your option) any later version. | |
eb46d7af | 7 | * |
d3cf93bc NJ |
8 | * This library is distributed in the hope that it will be useful, |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | * Lesser General Public License for more details. | |
eb46d7af | 12 | * |
d3cf93bc NJ |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
eb46d7af MD |
16 | */ |
17 | ||
18 | \f | |
19 | ||
20 | /* From NEWS: | |
21 | * | |
22 | * * New primitive: `simple-format', affects `scm-error', scm_display_error, & scm_error message strings | |
23 | * | |
24 | * (ice-9 boot) makes `format' an alias for `simple-format' until possibly | |
25 | * extended by the more sophisticated version in (ice-9 format) | |
26 | * | |
27 | * (simple-format port message . args) | |
28 | * Write MESSAGE to DESTINATION, defaulting to `current-output-port'. | |
29 | * MESSAGE can contain ~A (was %s) and ~S (was %S) escapes. When printed, | |
30 | * the escapes are replaced with corresponding members of ARGS: | |
31 | * ~A formats using `display' and ~S formats using `write'. | |
32 | * If DESTINATION is #t, then use the `current-output-port', | |
33 | * if DESTINATION is #f, then return a string containing the formatted text. | |
34 | * Does not add a trailing newline." | |
35 | * | |
36 | * The two C procedures: scm_display_error and scm_error, as well as the | |
37 | * primitive `scm-error', now use scm_format to do their work. This means | |
38 | * that the message strings of all code must be updated to use ~A where %s | |
39 | * was used before, and ~S where %S was used before. | |
40 | * | |
41 | * During the period when there still are a lot of old Guiles out there, | |
42 | * you might want to support both old and new versions of Guile. | |
43 | * | |
44 | * There are basically two methods to achieve this. Both methods use | |
45 | * autoconf. Put | |
46 | * | |
47 | * AC_CHECK_FUNCS(scm_simple_format) | |
48 | * | |
49 | * in your configure.in. | |
50 | * | |
51 | * Method 1: Use the string concatenation features of ANSI C's | |
52 | * preprocessor. | |
53 | * | |
54 | * In C: | |
55 | * | |
56 | * #ifdef HAVE_SCM_SIMPLE_FORMAT | |
57 | * #define FMT_S "~S" | |
58 | * #else | |
59 | * #define FMT_S "%S" | |
60 | * #endif | |
61 | * | |
62 | * Then represent each of your error messages using a preprocessor macro: | |
63 | * | |
64 | * #define E_SPIDER_ERROR "There's a spider in your " ## FMT_S ## "!!!" | |
65 | * | |
66 | * In Scheme: | |
67 | * | |
68 | * (define fmt-s (if (defined? 'simple-format) "~S" "%S")) | |
69 | * (define make-message string-append) | |
70 | * | |
71 | * (define e-spider-error | |
72 | * (make-message "There's a spider in your " fmt-s "!!!")) | |
73 | * | |
74 | * Method 2: Use the oldfmt function found in doc/oldfmt.c. | |
75 | * | |
76 | * In C: | |
77 | * | |
78 | * scm_misc_error ("picnic", scm_c_oldfmt0 ("There's a spider in your ~S!!!"), | |
79 | * ...); | |
80 | * | |
81 | * In Scheme: | |
82 | * | |
83 | * (scm-error 'misc-error "picnic" (oldfmt "There's a spider in your ~S!!!") | |
84 | * ...) | |
85 | * | |
86 | */ | |
87 | ||
88 | /* | |
89 | * Take a format string FROM adhering to the new standard format (~A and ~S | |
90 | * as placeholders) of length N and return a string which is adapted | |
91 | * to the format used by the Guile interpreter which you are running. | |
92 | * | |
93 | * On successive calls with similar strings but different storage, the | |
94 | * same string with same storage is returned. This is necessary since | |
95 | * the existence of a garbage collector in the system may cause the same | |
96 | * format string to be represented with different storage at different | |
97 | * calls. | |
98 | */ | |
99 | ||
100 | char * | |
101 | scm_c_oldfmt (char *from, int n) | |
102 | { | |
103 | #ifdef HAVE_SCM_SIMPLE_FORMAT | |
104 | return from; | |
105 | #else | |
106 | static struct { int n; char *from; char *to; } *strings; | |
107 | static int size = 0; | |
108 | static int n_strings = 0; | |
109 | char *to; | |
110 | int i; | |
111 | ||
112 | for (i = 0; i < n_strings; ++i) | |
113 | if (n == strings[i].n && strncmp (from, strings[i].from, n) == 0) | |
114 | return strings[i].to; | |
115 | ||
116 | if (n_strings == size) | |
117 | { | |
118 | if (size == 0) | |
119 | { | |
120 | size = 10; | |
121 | strings = scm_must_malloc (size * sizeof (*strings), s_oldfmt); | |
122 | } | |
123 | else | |
124 | { | |
125 | int oldsize = size; | |
126 | size = 3 * oldsize / 2; | |
127 | strings = scm_must_realloc (strings, | |
128 | oldsize * sizeof (*strings), | |
129 | size * sizeof (*strings), | |
130 | s_oldfmt); | |
131 | } | |
132 | } | |
133 | ||
134 | strings[n_strings].n = n; | |
135 | strings[n_strings].from = strncpy (scm_must_malloc (n, s_oldfmt), from, n); | |
136 | to = strings[n_strings].to = scm_must_malloc (n + 1, s_oldfmt); | |
137 | n_strings++; | |
138 | ||
139 | for (i = 0; i < n; ++i) | |
140 | { | |
141 | if (from[i] == '~' && ++i < n) | |
142 | { | |
143 | if (from[i] == 'A') | |
144 | { | |
145 | to[i - 1] = '%'; | |
146 | to[i] = 's'; | |
147 | } | |
148 | else if (from[i] == 'S') | |
149 | { | |
150 | to[i - 1] = '%'; | |
151 | to[i] = 'S'; | |
152 | } | |
153 | else | |
154 | { | |
155 | to[i - 1] = '~'; | |
156 | to[i] = from[i]; | |
157 | } | |
158 | continue; | |
159 | } | |
160 | to[i] = from[i]; | |
161 | } | |
162 | to[i] = '\0'; | |
163 | ||
164 | return to; | |
165 | #endif | |
166 | } | |
167 | ||
168 | char * | |
169 | scm_c_oldfmt0 (char *s) | |
170 | { | |
171 | #ifdef HAVE_SCM_SIMPLE_FORMAT | |
172 | return s; | |
173 | #else | |
174 | return scm_c_oldfmt (s, strlen (s)); | |
175 | #endif | |
176 | } | |
177 | ||
178 | SCM_PROC (s_oldfmt, "oldfmt", 1, 0, 0, scm_oldfmt); | |
179 | ||
180 | SCM | |
181 | scm_oldfmt (SCM s) | |
182 | { | |
183 | #ifdef HAVE_SCM_SIMPLE_FORMAT | |
184 | return s; | |
185 | #else | |
186 | int n; | |
187 | SCM_ASSERT (SCM_NIMP (s) && SCM_STRINGP (s), s, 1, s_oldfmt); | |
188 | n = SCM_LENGTH (s); | |
36284627 DH |
189 | return scm_return_first (scm_mem2string (scm_c_oldfmt (SCM_ROCHARS (s), n), |
190 | n), | |
eb46d7af MD |
191 | s); |
192 | #endif | |
193 | } |