core: Bump MAX_STRING to 524288
[mes.git] / src / strings.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * GNU Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of GNU Mes.
6  *
7  * GNU Mes is free software; you can redistribute it and/or modify it
8  * under the terms of the GNU General Public License as published by
9  * the Free Software Foundation; either version 3 of the License, or (at
10  * your option) any later version.
11  *
12  * GNU Mes is distributed in the hope that it will be useful, but
13  * WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
19  */
20
21 #define MAX_STRING 524288
22 char g_buf[MAX_STRING];
23
24 void
25 assert_max_string (size_t i, char const* msg, char* string)
26 {
27   if (i > MAX_STRING) // Mes must be able to make g_buf
28     {
29       eputs (msg);
30       eputs (":string too long[");
31       eputs (itoa (i));
32       eputs ("]:");
33       string[MAX_STRING-1] = 0;
34       eputs (string);
35       error (cell_symbol_system_error, cell_f);
36     }
37 }
38
39 char const*
40 list_to_cstring (SCM list, size_t* size)
41 {
42   size_t i = 0;
43   char *p = g_buf;
44   while (list != cell_nil)
45     {
46       if (i > MAX_STRING)
47         assert_max_string (i, "list_to_string", g_buf);
48       g_buf[i++] = VALUE (car (list));
49       list = cdr (list);
50     }
51   g_buf[i] = 0;
52   *size = i;
53   return g_buf;
54 }
55
56 size_t
57 bytes_cells (size_t length)
58 {
59   return (1 + sizeof (long) + sizeof (long) + length + sizeof (SCM)) / sizeof (SCM);
60 }
61
62 SCM
63 make_bytes (char const* s, size_t length)
64 {
65   size_t size = bytes_cells (length);
66   SCM x = alloc (size);
67   TYPE (x) = TBYTES;
68   LENGTH (x) = length;
69   char *p = &g_cells[x].cdr;
70   if (!length)
71     *(char*)p = 0;
72   else
73     memcpy (p, s, length + 1);
74   if (g_debug > 2)
75     {
76       eputs ("make bytes: "); eputs (s); eputs ("\n");
77       eputs ("     bytes: "); eputs (CBYTES (x)); eputs ("\n");
78       eputs ("    length: "); eputs (itoa (length)); eputs ("\n");
79       eputs ("        ==> "); write_error_ (x);
80       eputs ("\n");
81     }
82   return x;
83 }
84
85 SCM
86 make_string (char const* s, size_t length)
87 {
88   if (length > MAX_STRING)
89     assert_max_string (length, "make_string", s);
90   SCM x = make_cell__ (TSTRING, length, 0);
91   SCM v = make_bytes (s, length);
92   CDR (x) = v;
93   return x;
94 }
95
96 SCM
97 string_equal_p (SCM a, SCM b) ///((name . "string=?"))
98 {
99   if (! ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
100          || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
101     {
102       eputs ("type a: "); eputs (itoa (TYPE (a))); eputs ("\n");
103       eputs ("type b: "); eputs (itoa (TYPE (b))); eputs ("\n");
104       eputs ("a= "); write_error_ (a); eputs ("\n");
105       eputs ("b= "); write_error_ (b); eputs ("\n");
106       assert ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
107               || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD));
108     }
109   if (g_debug == -1)
110     {
111       eputs ("string=?: "); eputs (CSTRING (a));
112       eputs (" =? "); eputs (CSTRING (b));
113     }
114   if (a == b
115       || STRING (a) == STRING (b)
116       || (!LENGTH (a) && !LENGTH (b))
117       || (LENGTH (a) == LENGTH (b)
118           && !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
119     {
120       if (g_debug == -1)
121         eputs (" => #t\n");
122       return cell_t;
123     }
124   if (g_debug == -1)
125     eputs (" => #f\n");
126   return cell_f;
127 }
128
129 SCM
130 symbol_to_string (SCM symbol)
131 {
132   SCM x = make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
133
134   if (g_debug > 2)
135     {
136       eputs ("symbol->string: "); eputs (CSTRING (x)); eputs ("\n");
137       eputs ("  was: "); write_error_ (symbol);
138       eputs ("==> "); write_error_ (x);
139       eputs ("\n");
140     }
141   return x;
142 }
143
144 SCM
145 symbol_to_keyword (SCM symbol)
146 {
147   SCM x = make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
148
149   if (g_debug > 2)
150     {
151       eputs ("symbol->keyword: "); eputs (CSTRING (x)); eputs ("\n");
152       eputs ("  was: "); write_error_ (symbol);
153       eputs ("==> "); write_error_ (x);
154       eputs ("\n");
155     }
156   return x;
157 }
158
159 SCM
160 keyword_to_string (SCM keyword)
161 {
162   SCM x = make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
163
164   if (g_debug > 2)
165     {
166       eputs ("keyword->string: "); eputs (CSTRING (x)); eputs ("\n");
167       eputs ("  was: "); write_error_ (keyword);
168       eputs ("==> "); write_error_ (x);
169       eputs ("\n");
170     }
171   return x;
172 }
173
174 SCM
175 string_to_symbol (SCM string)
176 {
177   SCM x = hash_ref (g_symbols, string, cell_f);
178   if (x == cell_f)
179     x = make_symbol (string);
180   return x;
181 }
182
183 SCM
184 make_symbol (SCM string)
185 {
186   SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
187   hash_set_x (g_symbols, string, x);
188
189   if (g_debug > 3)
190     hash_table_printer (g_symbols);
191
192   if (g_debug > 2)
193     {
194       eputs ("make_symbol: "); eputs (CSTRING (string)); eputs ("\n");
195       eputs ("==> "); write_error_ (x);
196       eputs ("\n");
197     }
198
199   return x;
200 }
201
202 SCM
203 bytes_to_list (char const* s, size_t i)
204 {
205   SCM p = cell_nil;
206   while (i--)
207     {
208       int c = (0x100 + s[i]) % 0x100;
209       p = cons (MAKE_CHAR (c), p);
210     }
211   return p;
212 }
213
214 SCM
215 cstring_to_list (char const* s)
216 {
217   return bytes_to_list (s, strlen (s));
218 }
219
220 SCM
221 cstring_to_symbol (char const *s)
222 {
223   SCM string = MAKE_STRING0 (s);
224   return string_to_symbol (string);
225 }
226
227 SCM
228 string_to_list (SCM string)
229 {
230   return bytes_to_list (CSTRING (string), LENGTH (string));
231 }
232
233 SCM
234 list_to_string (SCM list)
235 {
236   size_t size;
237   char const *s = list_to_cstring (list, &size);
238   return make_string (s, size);
239 }
240
241 SCM
242 read_string (SCM port) ///((arity . n))
243 {
244   int fd = g_stdin;
245   if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
246     g_stdin = VALUE (CAR (port));
247   int c = readchar ();
248   size_t i = 0;
249   while (c != -1)
250     {
251       if (i > MAX_STRING)
252         assert_max_string (i, "read_string", g_buf);
253       g_buf[i++] = c;
254       c = readchar ();
255     }
256   g_buf[i] = 0;
257   g_stdin = fd;
258   return make_string (g_buf, i);
259 }
260
261 SCM
262 string_append (SCM x) ///((arity . n))
263 {
264   char const *p = g_buf;
265   g_buf[0] = 0;
266   size_t size = 0;
267   while (x != cell_nil)
268     {
269       SCM string = CAR (x);
270       assert (TYPE (string) == TSTRING);
271       memcpy (p, CSTRING (string), LENGTH (string) + 1);
272       p += LENGTH (string);
273       size += LENGTH (string);
274       if (size > MAX_STRING)
275         assert_max_string (size, "string_append", g_buf);
276       x = CDR (x);
277     }
278   return make_string (g_buf, size);
279 }
280
281 SCM
282 string_length (SCM string)
283 {
284   assert (TYPE (string) == TSTRING);
285   return MAKE_NUMBER (LENGTH (string));
286 }
287
288 SCM
289 string_ref (SCM str, SCM k)
290 {
291   assert (TYPE (str) == TSTRING);
292   assert (TYPE (k) == TNUMBER);
293   size_t size = LENGTH (str);
294   size_t i = VALUE (k);
295   if (i > size)
296     error (cell_symbol_system_error, cons (MAKE_STRING0 ("value out of range"), k));
297   char const *p = CSTRING (str);
298   return MAKE_CHAR (p[i]);
299 }