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