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