adb6feed363864484f1b2e71fbe2a9c91b6af880
[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   return x;
75 }
76
77 SCM
78 make_string (char const* s, size_t length)
79 {
80   if (length > MAX_STRING)
81     assert_max_string (length, "make_string", s);
82   SCM x = make_cell__ (TSTRING, length, 0);
83   SCM v = make_bytes (s, length);
84   CDR (x) = v;
85   return x;
86 }
87
88 SCM
89 string_equal_p (SCM a, SCM b) ///((name . "string=?"))
90 {
91   if (! ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
92          || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
93     {
94       eputs ("type a: "); eputs (itoa (TYPE (a))); eputs ("\n");
95       eputs ("type b: "); eputs (itoa (TYPE (b))); eputs ("\n");
96       eputs ("a= "); write_error_ (a); eputs ("\n");
97       eputs ("b= "); write_error_ (b); eputs ("\n");
98       assert ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
99               || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD));
100     }
101   if (a == b
102       || STRING (a) == STRING (b)
103       || (!LENGTH (a) && !LENGTH (b))
104       || (LENGTH (a) == LENGTH (b)
105           && !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
106     return cell_t;
107   return cell_f;
108 }
109
110 SCM
111 symbol_to_string (SCM symbol)
112 {
113   return make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
114 }
115
116 SCM
117 symbol_to_keyword (SCM symbol)
118 {
119   return make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
120 }
121
122 SCM
123 keyword_to_string (SCM keyword)
124 {
125   return make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
126 }
127
128 SCM
129 string_to_symbol (SCM string)
130 {
131   SCM x = hash_ref (g_symbols, string, cell_f);
132   if (x == cell_f)
133     x = make_symbol (string);
134   return x;
135 }
136
137 SCM
138 make_symbol (SCM string)
139 {
140   SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
141   hash_set_x (g_symbols, string, x);
142   return x;
143 }
144
145 SCM
146 bytes_to_list (char const* s, size_t i)
147 {
148   SCM p = cell_nil;
149   while (i--)
150     {
151       int c = (0x100 + s[i]) % 0x100;
152       p = cons (MAKE_CHAR (c), p);
153     }
154   return p;
155 }
156
157 SCM
158 cstring_to_list (char const* s)
159 {
160   return bytes_to_list (s, strlen (s));
161 }
162
163 SCM
164 cstring_to_symbol (char const *s)
165 {
166   SCM string = MAKE_STRING0 (s);
167   return string_to_symbol (string);
168 }
169
170 SCM
171 string_to_list (SCM string)
172 {
173   return bytes_to_list (CSTRING (string), LENGTH (string));
174 }
175
176 SCM
177 list_to_string (SCM list)
178 {
179   size_t size;
180   char const *s = list_to_cstring (list, &size);
181   return make_string (s, size);
182 }
183
184 SCM
185 read_string (SCM port) ///((arity . n))
186 {
187   int fd = g_stdin;
188   if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
189     g_stdin = VALUE (CAR (port));
190   int c = readchar ();
191   size_t i = 0;
192   while (c != -1)
193     {
194       if (i > MAX_STRING)
195         assert_max_string (i, "read_string", g_buf);
196       g_buf[i++] = c;
197       c = readchar ();
198     }
199   g_buf[i] = 0;
200   g_stdin = fd;
201   return make_string (g_buf, i);
202 }
203
204 SCM
205 string_append (SCM x) ///((arity . n))
206 {
207   char const *p = g_buf;
208   g_buf[0] = 0;
209   size_t size = 0;
210   while (x != cell_nil)
211     {
212       SCM string = CAR (x);
213       assert (TYPE (string) == TSTRING);
214       memcpy (p, CSTRING (string), LENGTH (string) + 1);
215       p += LENGTH (string);
216       size += LENGTH (string);
217       if (size > MAX_STRING)
218         assert_max_string (size, "string_append", g_buf);
219       x = CDR (x);
220     }
221   return make_string (g_buf, size);
222 }
223
224 SCM
225 string_length (SCM string)
226 {
227   assert (TYPE (string) == TSTRING);
228   return MAKE_NUMBER (LENGTH (string));
229 }
230
231 SCM
232 string_ref (SCM str, SCM k)
233 {
234   assert (TYPE (str) == TSTRING);
235   assert (TYPE (k) == TNUMBER);
236   size_t size = LENGTH (str);
237   size_t i = VALUE (k);
238   if (i > size)
239     error (cell_symbol_system_error, cons (MAKE_STRING0 ("value out of range"), k));
240   char const *p = CSTRING (str);
241   return MAKE_CHAR (p[i]);
242 }