1 /* -*-comment-start: "//";comment-end:""-*-
2 * GNU Mes --- Maxwell Equations of Software
3 * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 * This file is part of GNU Mes.
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.
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.
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/>.
22 assert_max_string (size_t i, char const* msg, char* string)
27 eputs (":string too long[");
30 string[MAX_STRING-1] = 0;
32 error (cell_symbol_system_error, cell_f);
37 list_to_cstring (SCM list, size_t* size)
41 while (list != cell_nil)
44 assert_max_string (i, "list_to_string", g_buf);
45 g_buf[i++] = VALUE (car (list));
54 bytes_cells (size_t length)
56 return (1 + sizeof (long) + sizeof (long) + length + sizeof (SCM)) / sizeof (SCM);
60 make_bytes (char const* s, size_t length)
62 size_t size = bytes_cells (length);
66 char *p = (char*)&g_cells[x].cdr;
70 memcpy (p, s, length + 1);
75 make_string (char const* s, size_t length)
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);
86 string_equal_p (SCM a, SCM b) ///((name . "string=?"))
88 if (! ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
89 || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
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));
99 || STRING (a) == STRING (b)
100 || (!LENGTH (a) && !LENGTH (b))
101 || (LENGTH (a) == LENGTH (b)
102 && !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
108 symbol_to_string (SCM symbol)
110 return make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
114 symbol_to_keyword (SCM symbol)
116 return make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
120 keyword_to_string (SCM keyword)
122 return make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
126 string_to_symbol (SCM string)
128 SCM x = hash_ref (g_symbols, string, cell_f);
130 x = make_symbol (string);
135 make_symbol (SCM string)
137 SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
138 hash_set_x (g_symbols, string, x);
143 bytes_to_list (char const* s, size_t i)
148 int c = (0x100 + s[i]) % 0x100;
149 p = cons (MAKE_CHAR (c), p);
155 cstring_to_list (char const* s)
157 return bytes_to_list (s, strlen (s));
161 cstring_to_symbol (char const *s)
163 SCM string = MAKE_STRING0 (s);
164 return string_to_symbol (string);
168 string_to_list (SCM string)
170 return bytes_to_list (CSTRING (string), LENGTH (string));
174 list_to_string (SCM list)
177 char const *s = list_to_cstring (list, &size);
178 return make_string (s, size);
182 read_string (SCM port) ///((arity . n))
185 if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
186 __stdin = VALUE (CAR (port));
192 assert_max_string (i, "read_string", g_buf);
198 return make_string (g_buf, i);
202 string_append (SCM x) ///((arity . n))
207 while (x != cell_nil)
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);
218 return make_string (g_buf, size);
222 string_length (SCM string)
224 assert (TYPE (string) == TSTRING);
225 return MAKE_NUMBER (LENGTH (string));
229 string_ref (SCM str, SCM k)
231 assert (TYPE (str) == TSTRING);
232 assert (TYPE (k) == TNUMBER);
233 size_t size = LENGTH (str);
234 size_t i = VALUE (k);
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]);