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 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 }