86828461ce6c2f82803a116ebe225d9dcea5ef6f
[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 #include <string.h>
22
23 #define MAX_STRING 4096
24
25 char const*
26 list_to_cstring (SCM list, size_t* size)
27 {
28   static char buf[MAX_STRING];
29   size_t i = 0;
30   char *p = buf;
31   while (list != cell_nil)
32     {
33       assert (i < MAX_STRING);
34       buf[i++] = VALUE (car (list));
35       list = cdr (list);
36     }
37   buf[i] = 0;
38   *size = i;
39   return buf;
40 }
41
42 size_t
43 bytes_cells (size_t length)
44 {
45   return (1 + sizeof (long) + sizeof (long) + length + sizeof (SCM)) / sizeof (SCM);
46 }
47
48 SCM
49 make_bytes (char const* s, size_t length)
50 {
51   size_t size = bytes_cells (length);
52   SCM x = alloc (size);
53   TYPE (x) = TBYTES;
54   LENGTH (x) = length;
55   char *p = &g_cells[x].cdr;
56   if (!length)
57     *(char*)p = 0;
58   else
59     memcpy (p, s, length + 1);
60   if (g_debug > 2)
61     {
62       eputs ("make bytes: "); eputs (s); eputs ("\n");
63       eputs ("     bytes: "); eputs (CBYTES (x)); eputs ("\n");
64       eputs ("    length: "); eputs (itoa (length)); eputs ("\n");
65       eputs ("        ==> "); write_error_ (x);
66       eputs ("\n");
67     }
68   return x;
69 }
70
71 SCM
72 make_string (char const* s, size_t length)
73 {
74   assert (length < HALFLONG_MAX);
75   SCM x = make_cell__ (TSTRING, length, 0);
76   SCM v = make_bytes (s, length);
77   CDR (x) = v;
78   return x;
79 }
80
81 SCM
82 string_equal_p (SCM a, SCM b) ///((name . "string=?"))
83 {
84   if (! ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
85          || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
86     {
87       eputs ("type a: "); eputs (itoa (TYPE (a))); eputs ("\n");
88       eputs ("type b: "); eputs (itoa (TYPE (b))); eputs ("\n");
89       eputs ("a= "); write_error_ (a); eputs ("\n");
90       eputs ("b= "); write_error_ (b); eputs ("\n");
91       assert ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
92               || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD));
93     }
94   if (g_debug == -1)
95     {
96       eputs ("string=?: "); eputs (CSTRING (a));
97       eputs (" =? "); eputs (CSTRING (b));
98     }
99   if (a == b
100       || STRING (a) == STRING (b)
101       || (!LENGTH (a) && !LENGTH (b))
102       || (LENGTH (a) == LENGTH (b)
103           && !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
104     {
105       if (g_debug == -1)
106         eputs (" => #t\n");
107       return cell_t;
108     }
109   if (g_debug == -1)
110     eputs (" => #f\n");
111   return cell_f;
112 }
113
114 SCM
115 symbol_to_string (SCM symbol)
116 {
117   SCM x = make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
118
119   if (g_debug > 2)
120     {
121       eputs ("symbol->string: "); eputs (CSTRING (x)); eputs ("\n");
122       eputs ("  was: "); write_error_ (symbol);
123       eputs ("==> "); write_error_ (x);
124       eputs ("\n");
125     }
126   return x;
127 }
128
129 SCM
130 symbol_to_keyword (SCM symbol)
131 {
132   SCM x = make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
133
134   if (g_debug > 2)
135     {
136       eputs ("symbol->keyword: "); 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 keyword_to_string (SCM keyword)
146 {
147   SCM x = make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
148
149   if (g_debug > 2)
150     {
151       eputs ("keyword->string: "); eputs (CSTRING (x)); eputs ("\n");
152       eputs ("  was: "); write_error_ (keyword);
153       eputs ("==> "); write_error_ (x);
154       eputs ("\n");
155     }
156   return x;
157 }
158
159 SCM
160 string_to_symbol (SCM string)
161 {
162   SCM x = hash_ref (g_symbols, string, cell_f);
163   if (x == cell_f)
164     x = make_symbol (string);
165   return x;
166 }
167
168 SCM
169 make_symbol (SCM string)
170 {
171   SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
172   hash_set_x (g_symbols, string, x);
173
174   if (g_debug > 3)
175     hash_table_printer (g_symbols);
176
177   if (g_debug > 2)
178     {
179       eputs ("make_symbol: "); eputs (CSTRING (string)); eputs ("\n");
180       eputs ("==> "); write_error_ (x);
181       eputs ("\n");
182     }
183
184   return x;
185 }
186
187 SCM
188 bytes_to_list (char const* s, size_t i)
189 {
190   SCM p = cell_nil;
191   while (i--)
192     {
193       int c = (0x100 + s[i]) % 0x100;
194       p = cons (MAKE_CHAR (c), p);
195     }
196   return p;
197 }
198
199 SCM
200 cstring_to_list (char const* s)
201 {
202   return bytes_to_list (s, strlen (s));
203 }
204
205 SCM
206 cstring_to_symbol (char const *s)
207 {
208   SCM string = MAKE_STRING0 (s);
209   return string_to_symbol (string);
210 }
211
212 SCM
213 string_to_list (SCM string)
214 {
215   return bytes_to_list (CSTRING (string), LENGTH (string));
216 }
217
218 SCM
219 list_to_string (SCM list)
220 {
221   size_t size;
222   char const *s = list_to_cstring (list, &size);
223   return make_string (s, size);
224 }
225
226 SCM
227 read_string (SCM port) ///((arity . n))
228 {
229   int fd = g_stdin;
230   if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
231     g_stdin = VALUE (CAR (port));
232   int c = readchar ();
233   static char buf[MAX_STRING];
234   size_t i = 0;
235   while (c != -1)
236     {
237       assert (i < MAX_STRING);
238       buf[i++] = c;
239       c = readchar ();
240     }
241   buf[i] = 0;
242   g_stdin = fd;
243   return make_string (buf, i);
244 }
245
246 SCM
247 string_append (SCM x) ///((arity . n))
248 {
249   static char buf[MAX_STRING];
250   char const *p = buf;
251   buf[0] = 0;
252   size_t size = 0;
253   while (x != cell_nil)
254     {
255       SCM string = CAR (x);
256       assert (TYPE (string) == TSTRING);
257       memcpy (p, CSTRING (string), LENGTH (string) + 1);
258       p += LENGTH (string);
259       size += LENGTH (string);
260       assert (size < MAX_STRING);
261       x = CDR (x);
262     }
263   return make_string (buf, size);
264 }
265
266 SCM
267 string_length (SCM string)
268 {
269   assert (TYPE (string) == TSTRING);
270   return MAKE_NUMBER (LENGTH (string));
271 }
272
273 SCM
274 string_ref (SCM str, SCM k)
275 {
276   assert (TYPE (str) == TSTRING);
277   assert (TYPE (k) == TNUMBER);
278   size_t size = LENGTH (str);
279   size_t i = VALUE (k);
280   if (i >= size)
281     error (cell_symbol_system_error, cons (MAKE_STRING0 ("value out of range"), k));
282   char const *p = CSTRING (str);
283   return MAKE_CHAR (p[i]);
284 }