2018-11-11 15:25:36 +00:00
|
|
|
/* -*-comment-start: "//";comment-end:""-*-
|
|
|
|
* GNU Mes --- Maxwell Equations of Software
|
2020-04-20 17:47:18 +00:00
|
|
|
* Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
2018-11-11 15:25:36 +00:00
|
|
|
*
|
|
|
|
* This file is part of GNU Mes.
|
|
|
|
*
|
|
|
|
* GNU Mes is free software; you can redistribute it and/or modify it
|
|
|
|
* under the terms of the GNU General Public License as published by
|
|
|
|
* the Free Software Foundation; either version 3 of the License, or (at
|
|
|
|
* your option) any later version.
|
|
|
|
*
|
|
|
|
* GNU Mes is distributed in the hope that it will be useful, but
|
|
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
* GNU General Public License for more details.
|
|
|
|
*
|
|
|
|
* You should have received a copy of the GNU General Public License
|
|
|
|
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
*/
|
|
|
|
|
2019-06-08 13:36:22 +00:00
|
|
|
#include "mes/lib.h"
|
|
|
|
#include "mes/mes.h"
|
|
|
|
|
|
|
|
#include <limits.h>
|
|
|
|
#include <string.h>
|
|
|
|
|
2018-12-15 09:34:57 +00:00
|
|
|
void
|
2019-05-18 11:27:42 +00:00
|
|
|
assert_max_string (size_t i, char const *msg, char *string)
|
2018-12-15 09:34:57 +00:00
|
|
|
{
|
2019-02-10 05:56:06 +00:00
|
|
|
if (i > MAX_STRING)
|
2018-12-15 09:34:57 +00:00
|
|
|
{
|
|
|
|
eputs (msg);
|
|
|
|
eputs (":string too long[");
|
|
|
|
eputs (itoa (i));
|
|
|
|
eputs ("]:");
|
2019-05-18 11:27:42 +00:00
|
|
|
string[MAX_STRING - 1] = 0;
|
2018-12-15 09:34:57 +00:00
|
|
|
eputs (string);
|
|
|
|
error (cell_symbol_system_error, cell_f);
|
|
|
|
}
|
|
|
|
}
|
2018-11-11 15:25:36 +00:00
|
|
|
|
2019-05-18 11:27:42 +00:00
|
|
|
char const *
|
2020-04-19 09:36:18 +00:00
|
|
|
list_to_cstring (SCM list, size_t *size)
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
|
|
|
size_t i = 0;
|
2018-12-15 09:34:57 +00:00
|
|
|
char *p = g_buf;
|
2018-11-11 15:25:36 +00:00
|
|
|
while (list != cell_nil)
|
|
|
|
{
|
2018-12-15 09:34:57 +00:00
|
|
|
if (i > MAX_STRING)
|
|
|
|
assert_max_string (i, "list_to_string", g_buf);
|
2020-04-20 17:47:18 +00:00
|
|
|
g_buf[i] = VALUE (car (list));
|
|
|
|
i = i + 1;
|
2018-11-11 15:25:36 +00:00
|
|
|
list = cdr (list);
|
|
|
|
}
|
2018-12-15 09:34:57 +00:00
|
|
|
g_buf[i] = 0;
|
2020-04-20 17:47:18 +00:00
|
|
|
size[0] = i;
|
|
|
|
|
2018-12-15 09:34:57 +00:00
|
|
|
return g_buf;
|
2018-11-11 15:25:36 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
size_t
|
|
|
|
bytes_cells (size_t length)
|
|
|
|
{
|
|
|
|
return (1 + sizeof (long) + sizeof (long) + length + sizeof (SCM)) / sizeof (SCM);
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
2019-05-18 11:27:42 +00:00
|
|
|
make_bytes (char const *s, size_t length)
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
|
|
|
size_t size = bytes_cells (length);
|
|
|
|
SCM x = alloc (size);
|
|
|
|
TYPE (x) = TBYTES;
|
|
|
|
LENGTH (x) = length;
|
2020-04-20 17:47:18 +00:00
|
|
|
#if __M2_PLANET__
|
|
|
|
char *p = &g_cells[x];
|
|
|
|
p = p + 2 * sizeof (SCM);
|
|
|
|
#else
|
|
|
|
char *p = &CDR (x);
|
|
|
|
#endif
|
|
|
|
if (length == 0)
|
|
|
|
p[0] = 0;
|
2018-11-11 15:25:36 +00:00
|
|
|
else
|
|
|
|
memcpy (p, s, length + 1);
|
2020-04-20 17:47:18 +00:00
|
|
|
|
2018-11-11 15:25:36 +00:00
|
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
2019-05-18 11:27:42 +00:00
|
|
|
make_string (char const *s, size_t length)
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
2018-12-15 09:34:57 +00:00
|
|
|
if (length > MAX_STRING)
|
2020-04-20 17:47:18 +00:00
|
|
|
assert_max_string (length, "make_string", s);
|
2018-11-11 15:25:36 +00:00
|
|
|
SCM x = make_cell__ (TSTRING, length, 0);
|
|
|
|
SCM v = make_bytes (s, length);
|
|
|
|
CDR (x) = v;
|
|
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
2020-04-20 17:47:18 +00:00
|
|
|
string_equal_p (SCM a, SCM b) /*:((name . "string=?")) */
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
2019-05-18 11:27:42 +00:00
|
|
|
if (!((TYPE (a) == TSTRING && TYPE (b) == TSTRING) || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
2019-05-18 11:27:42 +00:00
|
|
|
eputs ("type a: ");
|
|
|
|
eputs (itoa (TYPE (a)));
|
|
|
|
eputs ("\n");
|
|
|
|
eputs ("type b: ");
|
|
|
|
eputs (itoa (TYPE (b)));
|
|
|
|
eputs ("\n");
|
|
|
|
eputs ("a= ");
|
|
|
|
write_error_ (a);
|
|
|
|
eputs ("\n");
|
|
|
|
eputs ("b= ");
|
|
|
|
write_error_ (b);
|
|
|
|
eputs ("\n");
|
2020-05-17 14:07:04 +00:00
|
|
|
assert_msg ((TYPE (a) == TSTRING && TYPE (b) == TSTRING) || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD), "(TYPE (a) == TSTRING && TYPE (b) == TSTRING) || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)");
|
2018-11-11 15:25:36 +00:00
|
|
|
}
|
|
|
|
if (a == b
|
|
|
|
|| STRING (a) == STRING (b)
|
2020-04-20 17:47:18 +00:00
|
|
|
|| (LENGTH (a) == 0 && LENGTH (b) == 0)
|
2019-05-18 11:27:42 +00:00
|
|
|
|| (LENGTH (a) == LENGTH (b) && !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
|
2018-12-27 15:48:45 +00:00
|
|
|
return cell_t;
|
2020-04-20 17:47:18 +00:00
|
|
|
|
2018-11-11 15:25:36 +00:00
|
|
|
return cell_f;
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
symbol_to_string (SCM symbol)
|
|
|
|
{
|
2018-12-27 15:48:45 +00:00
|
|
|
return make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
|
2018-11-11 15:25:36 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
symbol_to_keyword (SCM symbol)
|
|
|
|
{
|
2018-12-27 15:48:45 +00:00
|
|
|
return make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
|
2018-11-11 15:25:36 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
keyword_to_string (SCM keyword)
|
|
|
|
{
|
2018-12-27 15:48:45 +00:00
|
|
|
return make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
|
2018-11-11 15:25:36 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
string_to_symbol (SCM string)
|
|
|
|
{
|
|
|
|
SCM x = hash_ref (g_symbols, string, cell_f);
|
|
|
|
if (x == cell_f)
|
|
|
|
x = make_symbol (string);
|
|
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
make_symbol (SCM string)
|
|
|
|
{
|
|
|
|
SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
|
|
|
|
hash_set_x (g_symbols, string, x);
|
|
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
2019-05-18 11:27:42 +00:00
|
|
|
bytes_to_list (char const *s, size_t i)
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
|
|
|
SCM p = cell_nil;
|
2020-04-20 17:47:18 +00:00
|
|
|
while (i != 0)
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
2020-04-20 17:47:18 +00:00
|
|
|
i = i - 1;
|
2018-11-11 15:25:36 +00:00
|
|
|
int c = (0x100 + s[i]) % 0x100;
|
|
|
|
p = cons (MAKE_CHAR (c), p);
|
|
|
|
}
|
|
|
|
return p;
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
2019-05-18 11:27:42 +00:00
|
|
|
cstring_to_list (char const *s)
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
|
|
|
return bytes_to_list (s, strlen (s));
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
cstring_to_symbol (char const *s)
|
|
|
|
{
|
|
|
|
SCM string = MAKE_STRING0 (s);
|
|
|
|
return string_to_symbol (string);
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
string_to_list (SCM string)
|
|
|
|
{
|
|
|
|
return bytes_to_list (CSTRING (string), LENGTH (string));
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
list_to_string (SCM list)
|
|
|
|
{
|
|
|
|
size_t size;
|
|
|
|
char const *s = list_to_cstring (list, &size);
|
|
|
|
return make_string (s, size);
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
2020-04-20 17:47:18 +00:00
|
|
|
read_string (SCM port) /*:((arity . n)) */
|
2018-11-11 15:25:36 +00:00
|
|
|
{
|
2019-03-02 11:35:18 +00:00
|
|
|
int fd = __stdin;
|
2018-11-11 15:25:36 +00:00
|
|
|
if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
|
2019-03-02 11:35:18 +00:00
|
|
|
__stdin = VALUE (CAR (port));
|
2018-11-11 15:25:36 +00:00
|
|
|
int c = readchar ();
|
|
|
|
size_t i = 0;
|
|
|
|
while (c != -1)
|
|
|
|
{
|
2018-12-15 09:34:57 +00:00
|
|
|
if (i > MAX_STRING)
|
|
|
|
assert_max_string (i, "read_string", g_buf);
|
2020-04-20 17:47:18 +00:00
|
|
|
g_buf[i] = c;
|
|
|
|
i = i + 1;
|
2018-11-11 15:25:36 +00:00
|
|
|
c = readchar ();
|
|
|
|
}
|
2018-12-15 09:34:57 +00:00
|
|
|
g_buf[i] = 0;
|
2019-03-02 11:35:18 +00:00
|
|
|
__stdin = fd;
|
2018-12-15 09:34:57 +00:00
|
|
|
return make_string (g_buf, i);
|
2018-11-11 15:25:36 +00:00
|
|
|
}
|
2018-11-15 22:09:56 +00:00
|
|
|
|
|
|
|
SCM
|
2020-04-20 17:47:18 +00:00
|
|
|
string_append (SCM x) /*:((arity . n)) */
|
2018-11-15 22:09:56 +00:00
|
|
|
{
|
2019-02-15 08:28:46 +00:00
|
|
|
char *p = g_buf;
|
2018-12-15 09:34:57 +00:00
|
|
|
g_buf[0] = 0;
|
2018-11-15 22:09:56 +00:00
|
|
|
size_t size = 0;
|
|
|
|
while (x != cell_nil)
|
|
|
|
{
|
|
|
|
SCM string = CAR (x);
|
2020-05-17 14:07:04 +00:00
|
|
|
assert_msg (TYPE (string) == TSTRING, "TYPE (string) == TSTRING");
|
2018-11-15 22:09:56 +00:00
|
|
|
memcpy (p, CSTRING (string), LENGTH (string) + 1);
|
2020-04-20 17:47:18 +00:00
|
|
|
p = p + LENGTH (string);
|
|
|
|
size = size + LENGTH (string);
|
2018-12-15 09:34:57 +00:00
|
|
|
if (size > MAX_STRING)
|
|
|
|
assert_max_string (size, "string_append", g_buf);
|
2018-11-15 22:09:56 +00:00
|
|
|
x = CDR (x);
|
|
|
|
}
|
2018-12-15 09:34:57 +00:00
|
|
|
return make_string (g_buf, size);
|
2018-11-15 22:09:56 +00:00
|
|
|
}
|
2018-11-15 22:51:29 +00:00
|
|
|
|
|
|
|
SCM
|
|
|
|
string_length (SCM string)
|
|
|
|
{
|
2020-05-17 14:07:04 +00:00
|
|
|
assert_msg (TYPE (string) == TSTRING, "TYPE (string) == TSTRING");
|
2018-11-15 22:51:29 +00:00
|
|
|
return MAKE_NUMBER (LENGTH (string));
|
|
|
|
}
|
2018-11-15 23:15:50 +00:00
|
|
|
|
|
|
|
SCM
|
|
|
|
string_ref (SCM str, SCM k)
|
|
|
|
{
|
2020-05-17 14:07:04 +00:00
|
|
|
assert_msg (TYPE (str) == TSTRING, "TYPE (str) == TSTRING");
|
|
|
|
assert_msg (TYPE (k) == TNUMBER, "TYPE (k) == TNUMBER");
|
2018-11-15 23:15:50 +00:00
|
|
|
size_t size = LENGTH (str);
|
|
|
|
size_t i = VALUE (k);
|
2018-12-15 09:34:57 +00:00
|
|
|
if (i > size)
|
2018-11-15 23:15:50 +00:00
|
|
|
error (cell_symbol_system_error, cons (MAKE_STRING0 ("value out of range"), k));
|
|
|
|
char const *p = CSTRING (str);
|
|
|
|
return MAKE_CHAR (p[i]);
|
|
|
|
}
|