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