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