1 /*-
2 * Copyright (c) 2005-2019 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)string.c 2.2 1/31/19
27 */
28
29 #if defined(HAVE_CONFIG_H)
30 #include "config.h"
31 #endif
32
33 #include "fth.h"
34 #include "utils.h"
35
36 /* === STRING === */
37
38 static FTH string_tag;
39
40 typedef struct {
41 ficlInteger length; /* actual string length */
42 ficlInteger buf_length; /* buffer length (bigger than actual
43 * string length) */
44 ficlInteger top; /* begin of actual string in buffer */
45 char *data; /* actual string */
46 char *buf; /* entire string buffer */
47 } FString;
48
49 #define MAKE_STRING_MEMBER(Type, Member) MAKE_MEMBER(FString, str, Type, Member)
50
51 /*-
52 * Build words for scrutinizing strings:
53 *
54 * init_str_length => str->length
55 * init_str_buf_length => str->buf_length
56 * init_str_top => str->top
57 */
58 MAKE_STRING_MEMBER(Integer, length)
59 MAKE_STRING_MEMBER(Integer, buf_length)
60 MAKE_STRING_MEMBER(Integer, top)
61
62 #define FTH_STRING_OBJECT(Obj) FTH_INSTANCE_REF_GEN(Obj, FString)
63 #define FTH_STRING_LENGTH(Obj) FTH_STRING_OBJECT(Obj)->length
64 #define FTH_STRING_BUF_LENGTH(Obj) FTH_STRING_OBJECT(Obj)->buf_length
65 #define FTH_STRING_TOP(Obj) FTH_STRING_OBJECT(Obj)->top
66 #define FTH_STRING_DATA(Obj) FTH_STRING_OBJECT(Obj)->data
67 #define FTH_STRING_BUF(Obj) FTH_STRING_OBJECT(Obj)->buf
68 #define FTH_STRING_REF(Obj) \
69 (FTH_STRING_P(Obj) ? FTH_STRING_DATA(Obj) : NULL)
70 #define FTH_STRREG_P(Obj) (FTH_STRING_P(Obj) || FTH_REGEXP_P(Obj))
71 #define FTH_TO_CCHAR(Obj) ((char)(FTH_TO_CHAR(Obj)))
72
73 static void ficl_char_p(ficlVm *);
74 static void ficl_cr_string(ficlVm *);
75 static void ficl_die(ficlVm *);
76 static void ficl_error(ficlVm *);
77 static void ficl_error_object(ficlVm *);
78 static void ficl_forth_string_to_string(ficlVm *);
79 static void ficl_fth_die(FTH, FTH);
80 static void ficl_fth_error(FTH, FTH);
81 static FTH ficl_fth_format(FTH, FTH);
82 static void ficl_fth_print(FTH, FTH);
83 static void ficl_fth_warning(FTH, FTH);
84 static void ficl_make_empty_string(ficlVm *);
85 static void ficl_make_string(ficlVm *);
86 static void ficl_make_string_im(ficlVm *);
87 static void ficl_print_debug(ficlVm *);
88 static void ficl_print_object(ficlVm *);
89 static void ficl_print_stderr(ficlVm *);
90 static void ficl_print_stdout(ficlVm *);
91 static void ficl_space_string(ficlVm *);
92 static void ficl_spaces_string(ficlVm *);
93 static void ficl_string_capitalize(ficlVm *);
94 static void ficl_string_capitalize_bang(ficlVm *);
95 static void ficl_string_chomp(ficlVm *);
96 static void ficl_string_chomp_bang(ficlVm *);
97 static void ficl_string_delete(ficlVm *);
98 static void ficl_string_downcase(ficlVm *);
99 static void ficl_string_downcase_bang(ficlVm *);
100 static void ficl_string_cmp(ficlVm *);
101 static void ficl_string_equal_p(ficlVm *);
102 static void ficl_string_eval(ficlVm *);
103 static void ficl_string_eval_with_status(ficlVm *);
104 static void ficl_string_greater_p(ficlVm *);
105 static void ficl_string_immutable_paren(ficlVm *);
106 static void ficl_string_insert(ficlVm *);
107 static void ficl_string_length(ficlVm *);
108 static void ficl_string_less_p(ficlVm *);
109 static void ficl_string_member_p(ficlVm *);
110 static void ficl_string_not_equal_p(ficlVm *);
111 static void ficl_string_p(ficlVm *);
112 static void ficl_string_ref(ficlVm *);
113 static void ficl_string_replace(ficlVm *);
114 static void ficl_string_replace_bang(ficlVm *);
115 static void ficl_string_reverse(ficlVm *);
116 static void ficl_string_reverse_bang(ficlVm *);
117 static void ficl_string_set(ficlVm *);
118 static void ficl_string_substring(ficlVm *);
119 static void ficl_string_to_forth_string(ficlVm *);
120 static void ficl_string_upcase(ficlVm *);
121 static void ficl_string_upcase_bang(ficlVm *);
122 static void ficl_values_to_string(ficlVm *);
123 static void ficl_warning(ficlVm *);
124 static FTH make_string_instance(FString *);
125 static FString *make_string_len(ficlInteger);
126 static FTH str_dump(FTH);
127 static FTH str_equal_p(FTH, FTH);
128 static void str_free(FTH);
129 static FTH str_inspect(FTH);
130 static FTH str_length(FTH);
131 static FTH str_ref(FTH, FTH);
132 static FTH str_set(FTH, FTH, FTH);
133 static FTH str_to_array(FTH);
134 static FTH str_to_string(FTH);
135
136 #define h_list_of_string_functions "\
137 *** STRING PRIMITIVES ***\n\
138 $+ alias for string-append\n\
139 $>string ( addr len -- str )\n\
140 $cr ( -- cr-str )\n\
141 $space ( -- space-str )\n\
142 $spaces ( len -- spaces-str )\n\
143 .$ alias for .string\n\
144 .debug ( obj -- )\n\
145 .error ( obj -- )\n\
146 .g alias for .string\n\
147 .stderr ( obj -- )\n\
148 .stdout ( obj -- )\n\
149 .string ( obj -- )\n\
150 << alias for string-push\n\
151 >string alias for string-concat\n\
152 \"\" ( -- empty-string )\n\
153 char? ( obj -- f )\n\
154 format alias for string-format\n\
155 fth-die ( fmt :optional args -- )\n\
156 fth-error ( fmt :optional args -- )\n\
157 fth-print ( fmt :optional args -- )\n\
158 fth-warning ( fmt :optional args -- )\n\
159 make-string ( len :key initial-element -- str )\n\
160 string->array ( str -- ary )\n\
161 string-append ( str1 str2 -- str3 )\n\
162 string-capitalize ( str1 -- str2 )\n\
163 string-capitalize! ( str -- str' )\n\
164 string-chomp ( str1 -- str2 )\n\
165 string-chomp! ( str -- str' )\n\
166 string-concat ( vals len -- str )\n\
167 string-copy ( str1 -- str2 )\n\
168 string-delete! ( str idx -- val )\n\
169 string-downcase ( str1 -- str2 )\n\
170 string-downcase! ( str -- str' )\n\
171 string-eval ( str -- ?? )\n\
172 string-eval-with-status ( str -- ?? status )\n\
173 string-fill ( str char -- str' )\n\
174 string-find ( str1 key -- str2 )\n\
175 string-format ( fmt args -- str )\n\
176 string-index ( str key -- idx|-1 )\n\
177 string-insert! ( str idx val -- str' )\n\
178 string-length ( str -- len )\n\
179 string-member? ( str key -- f )\n\
180 string-pop ( str -- char )\n\
181 string-push ( str str-or-else -- str' )\n\
182 string-ref ( str idx -- val )\n\
183 string-replace ( str1 c1 c2 -- str2 )\n\
184 string-replace! ( str c1 c2 -- str' )\n\
185 string-reverse ( str1 -- str2 )\n\
186 string-reverse! ( str -- str' )\n\
187 string-set! ( str idx val -- )\n\
188 string-shift ( str -- char )\n\
189 string-split ( str sep -- ary )\n\
190 string-substring ( str start end -- substr )\n\
191 string-unshift ( str val -- str' )\n\
192 string-upcase ( str1 -- str2 )\n\
193 string-upcase! ( str -- str' )\n\
194 string-cmp ( str1 str2 -- n )\n\
195 string< ( str1 str2 -- f )\n\
196 string<> ( str1 str2 -- f )\n\
197 string= ( str1 str2 -- f )\n\
198 string> ( str1 str2 -- f )\n\
199 string>$ ( str -- addr len )\n\
200 string? ( obj -- f )\n\
201 *** Eval exit constants:\n\
202 BREAK\n\
203 ERROR_EXIT\n\
204 INNER_EXIT\n\
205 OUT_OF_TEXT\n\
206 RESTART\n\
207 USER_EXIT"
208
209 static FTH
str_inspect(FTH self)210 str_inspect(FTH self)
211 {
212 return (fth_make_string_format("%s[%ld]: \"%s\"",
213 FTH_INSTANCE_NAME(self),
214 FTH_STRING_LENGTH(self),
215 FTH_STRING_DATA(self)));
216 }
217
218 static FTH
str_to_string(FTH self)219 str_to_string(FTH self)
220 {
221 return (fth_make_string(FTH_STRING_DATA(self)));
222 }
223
224 static FTH
str_dump(FTH self)225 str_dump(FTH self)
226 {
227 return (fth_make_string_format("\"%s\"", FTH_STRING_DATA(self)));
228 }
229
230 static FTH
str_to_array(FTH self)231 str_to_array(FTH self)
232 {
233 ficlInteger i;
234 FTH array;
235
236 array = fth_make_array_len(FTH_STRING_LENGTH(self));
237
238 for (i = 0; i < FTH_STRING_LENGTH(self); i++) {
239 FTH c;
240
241 c = CHAR_TO_FTH(FTH_STRING_DATA(self)[i]);
242 fth_array_fast_set(array, i, c);
243 }
244
245 return (array);
246 }
247
248 static FTH
str_ref(FTH self,FTH fidx)249 str_ref(FTH self, FTH fidx)
250 {
251 ficlInteger idx;
252
253 idx = FTH_INT_REF(fidx);
254
255 if (idx < 0 || idx >= FTH_STRING_LENGTH(self))
256 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
257
258 return (CHAR_TO_FTH(FTH_STRING_DATA(self)[idx]));
259 }
260
261 static FTH
str_set(FTH self,FTH fidx,FTH value)262 str_set(FTH self, FTH fidx, FTH value)
263 {
264 ficlInteger idx;
265
266 idx = FTH_INT_REF(fidx);
267
268 if (idx < 0 || idx >= FTH_STRING_LENGTH(self))
269 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
270
271 FTH_ASSERT_ARGS(FTH_CHAR_P(value), value, FTH_ARG3, "a char");
272 FTH_STRING_DATA(self)[idx] = FTH_TO_CCHAR(value);
273 FTH_INSTANCE_CHANGED(self);
274 return (value);
275 }
276
277 static FTH
str_equal_p(FTH self,FTH obj)278 str_equal_p(FTH self, FTH obj)
279 {
280 char *s, *o;
281
282 if (FTH_STRING_LENGTH(self) != FTH_STRING_LENGTH(obj))
283 return (FTH_FALSE);
284
285 if (FTH_STRING_LENGTH(self) == 0)
286 return (FTH_TRUE);
287
288 s = FTH_STRING_DATA(self);
289 o = FTH_STRING_DATA(obj);
290 return (BOOL_TO_FTH(strcmp(s, o) == 0));
291 }
292
293 static FTH
str_length(FTH self)294 str_length(FTH self)
295 {
296 return (fth_make_int(FTH_STRING_LENGTH(self)));
297 }
298
299 static void
str_free(FTH self)300 str_free(FTH self)
301 {
302 FTH_FREE(FTH_STRING_BUF(self));
303 FTH_FREE(FTH_STRING_OBJECT(self));
304 }
305
306 /*-
307 * Return C string from Fth OBJ or NULL if not a Fth string object.
308 *
309 * FTH fs = fth_make_string("hello");
310 * fth_string_ref(fs); => "hello"
311 * FTH fs = fth_make_empty_string();
312 * fth_string_ref(fs); => ""
313 * FTH fs = FTH_FALSE;
314 * fth_string_ref(fs); => NULL
315 */
316 char *
fth_string_ref(FTH obj)317 fth_string_ref(FTH obj)
318 {
319 return (FTH_STRING_P(obj) ? FTH_STRING_DATA(obj) : NULL);
320 }
321
322 /*-
323 * Return length of a Fth string object or -1 if not a string
324 * object.
325 *
326 * FTH fs = fth_make_string("hello");
327 * fth_string_length(fs); => 5
328 * fth_string_length((FTH)5); => -1 (means false)
329 */
330 ficlInteger
fth_string_length(FTH obj)331 fth_string_length(FTH obj)
332 {
333 return (FTH_STRING_P(obj) ? FTH_STRING_LENGTH(obj) : -1);
334 }
335
336 static void
ficl_string_length(ficlVm * vm)337 ficl_string_length(ficlVm *vm)
338 {
339 #define h_string_length "( str -- len ) return STR length\n\
340 \"hello\" string-length => 5\n\
341 5 string-length => -1\n\
342 If STR is a string object, return its length, otherwise -1."
343 FTH fs;
344
345 FTH_STACK_CHECK(vm, 1, 1);
346 fs = fth_pop_ficl_cell(vm);
347 ficlStackPushInteger(vm->dataStack, fth_string_length(fs));
348 }
349
350 static void
ficl_string_p(ficlVm * vm)351 ficl_string_p(ficlVm *vm)
352 {
353 #define h_string_p "( obj -- f ) test if OBJ is a string\n\
354 \"hello\" string? => #t\n\
355 nil string? => #f\n\
356 Return #t if OBJ is a string object, otherwise #f."
357 FTH obj;
358
359 FTH_STACK_CHECK(vm, 1, 1);
360 obj = fth_pop_ficl_cell(vm);
361 ficlStackPushBoolean(vm->dataStack, FTH_STRING_P(obj));
362 }
363
364 static void
ficl_char_p(ficlVm * vm)365 ficl_char_p(ficlVm *vm)
366 {
367 #define h_char_p "( obj -- f ) test if OBJ is a character\n\
368 <char> A char? => #t\n\
369 65 char? => #t\n\
370 10 char? => #f\n\
371 Return #t if OBJ is a character, otherwise #f."
372 FTH obj;
373
374 FTH_STACK_CHECK(vm, 1, 1);
375 obj = fth_pop_ficl_cell(vm);
376 ficlStackPushBoolean(vm->dataStack, FTH_CHAR_P(obj));
377 }
378
379 static FString *
make_string_len(ficlInteger len)380 make_string_len(ficlInteger len)
381 {
382 FString *s;
383 ficlInteger buf_len, top_len;
384
385 if (len < 0)
386 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "negative");
387
388 top_len = NEW_SEQ_LENGTH(len + 1) / 3;
389 buf_len = NEW_SEQ_LENGTH(len + 1 + top_len);
390
391 if (len > MAX_SEQ_LENGTH)
392 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
393
394 s = FTH_MALLOC(sizeof(FString));
395 s->length = len;
396 s->buf_length = buf_len;
397 s->top = top_len;
398 s->buf = FTH_CALLOC(s->buf_length, sizeof(char));
399 s->data = s->buf + s->top;
400 return (s);
401 }
402
403 static FTH
make_string_instance(FString * s)404 make_string_instance(FString *s)
405 {
406 if (s != NULL)
407 return (fth_make_instance(string_tag, s));
408
409 FTH_SYSTEM_ERROR_ARG_THROW(make_string, FTH_STR_STRING);
410 return (FTH_FALSE);
411 }
412
413 /*-
414 * Return a new Fth string object constructed from C string STR.
415 * If C string is "" or NULL, return Fth string "" in contrast to
416 * fth_make_string_or_false().
417 *
418 * FTH fs = fth_make_string("hello"); => "hello"
419 * fth_string_length(fs); => 5
420 * FTH fs = fth_make_string(""); => ""
421 * fth_string_length(fs); => 0
422 */
423 FTH
fth_make_string(const char * str)424 fth_make_string(const char *str)
425 {
426 FString *s;
427 size_t len;
428
429 if (str == NULL || *str == '\0')
430 str = "";
431
432 len = strlen(str);
433 s = make_string_len((ficlInteger) len);
434 memmove(s->data, str, len);
435 return (make_string_instance(s));
436 }
437
438 /*-
439 * If C string is "", return #f, otherwise like fth_make_string().
440 *
441 * FTH fs = fth_make_string_or_false("hello"); => "hello"
442 * fth_string_length(fs); => 5
443 * FTH fs = fth_make_string_or_false(""); => #f
444 * fth_string_length(fs); => -1 (means false)
445 */
446 FTH
fth_make_string_or_false(const char * str)447 fth_make_string_or_false(const char *str)
448 {
449 FString *s;
450 size_t len;
451
452 if (str == NULL || *str == '\0')
453 return (FTH_FALSE);
454
455 len = strlen(str);
456 s = make_string_len((ficlInteger) len);
457 memmove(s->data, str, len);
458 return (make_string_instance(s));
459 }
460
461 /*-
462 * Return a new Fth string object constructed from C string STR
463 * with at most LEN characters. If the C string STR is shorter
464 * than LEN, return a Fth string object of STR length only.
465 *
466 * FTH fs = fth_make_string_len(" ", 0); => ""
467 * FTH fs = fth_make_string_len(" ", 3); => " "
468 * FTH fs = fth_make_string_len("xxxxx", 3); => "xxx"
469 * FTH fs = fth_make_string_len("xxx", 5); => "xxx"
470 */
471 FTH
fth_make_string_len(const char * str,ficlInteger len)472 fth_make_string_len(const char *str, ficlInteger len)
473 {
474 FString *s;
475 size_t slen, blen;
476
477 if (str == NULL || *str == '\0')
478 str = "";
479
480 slen = strlen(str);
481 blen = FICL_MIN((size_t) len, slen);
482 s = make_string_len(blen);
483 memmove(s->data, str, blen);
484 s->data[blen] = '\0';
485 return (make_string_instance(s));
486 }
487
488 /*-
489 * Return a Fth string object of length 0.
490 *
491 * FTH fs = fth_make_empty_string(); => ""
492 * fth_string_length(fs); => 0
493 */
494 FTH
fth_make_empty_string(void)495 fth_make_empty_string(void)
496 {
497 FString *s;
498
499 s = make_string_len(0);
500 s->data[0] = '\0';
501 return (make_string_instance(s));
502 }
503
504 /*-
505 * Return a Fth string object according to the (extended) printf(3)
506 * fmt args. The extensions are:
507 *
508 * %I - fth_to_c_inspect print inspect string of Fth object
509 * %S - fth_to_c_string print string representation of object
510 * %M - fth_to_c_string_2 as fth_to_c_string but encloses
511 * strings in double quotes
512 * %D - fth_to_c_dump print dump string of Fth object
513 */
514 FTH
fth_make_string_format(const char * fmt,...)515 fth_make_string_format(const char *fmt,...)
516 {
517 char *str;
518 va_list ap;
519 FTH fs;
520
521 va_start(ap, fmt);
522 fth_vasprintf(&str, fmt, ap);
523 va_end(ap);
524 fs = fth_make_string(str);
525 FTH_FREE(str);
526 return (fs);
527 }
528
529 /*-
530 * These functions add C strings to an already existing Fth string
531 * object, the extended printf(3) fmt args are available for the
532 * last two of them. See fth_make_string_format above.
533 *
534 * fth_string_scat (FTH string, const char *str)
535 * fth_string_sncat (FTH string, const char *str, ficlInteger len)
536 * fth_string_sformat (FTH string, const char *fmt, ...)
537 * fth_string_vsformat(FTH string, const char *fmt, va_list ap)
538 *
539 * FTH fs = fth_make_empty_string(); => ""
540 * fth_string_scat(fs, "hello"); => "hello"
541 * fth_string_sncat(fs, ", ", 2); => "hello, "
542 * fth_string_sformat(fs, "%s!\n", "world"); => "hello, world!\n"
543 */
544 FTH
fth_string_scat(FTH fs,const char * str)545 fth_string_scat(FTH fs, const char *str)
546 {
547 return (fth_string_push(fs, fth_make_string(str)));
548 }
549
550 FTH
fth_string_sncat(FTH fs,const char * str,ficlInteger len)551 fth_string_sncat(FTH fs, const char *str, ficlInteger len)
552 {
553 return (fth_string_push(fs, fth_make_string_len(str, len)));
554 }
555
556 /*-
557 * Add extended printf(3) fmt args to an already existing Fth string
558 * object. See fth_make_string_format above.
559 *
560 * FTH fs = fth_make_string("we want to ");
561 * fth_string_sformat(fs, "print %d times %f\n", 10, 3.14);
562 * => "we want to print 10 times 3.140000\n"
563 */
564 FTH
fth_string_sformat(FTH fs,const char * fmt,...)565 fth_string_sformat(FTH fs, const char *fmt,...)
566 {
567 FTH s;
568 va_list ap;
569
570 va_start(ap, fmt);
571 s = fth_string_vsformat(fs, fmt, ap);
572 va_end(ap);
573 return (s);
574 }
575
576 /*
577 * The same as fth_string_sformat except for va_list args.
578 */
579 FTH
fth_string_vsformat(FTH fs,const char * fmt,va_list ap)580 fth_string_vsformat(FTH fs, const char *fmt, va_list ap)
581 {
582 char *str;
583 FTH s;
584
585 str = fth_vformat(fmt, ap);
586 s = fth_make_string(str);
587 FTH_FREE(str);
588 return (fth_string_push(fs, s));
589 }
590
591 static void
ficl_make_string(ficlVm * vm)592 ficl_make_string(ficlVm *vm)
593 {
594 #define h_make_string "( len :key initial-element ' ' -- str ) string\n\
595 0 make-string => \"\"\n\
596 3 make-string => \" \"\n\
597 3 :initial-element <char> x make-string => \"xxx\"\n\
598 Return a new string of length LEN filled with INITIAL-ELEMENT characters, \
599 default space. \
600 Raise an OUT-OF-RANGE exception if LEN < 0."
601 FTH size;
602 ficlInteger len;
603 int init;
604 FString *s;
605
606 init = fth_get_optkey_fix(FTH_KEYWORD_INIT, ' ');
607 FTH_STACK_CHECK(vm, 1, 1);
608 size = fth_pop_ficl_cell(vm);
609 FTH_ASSERT_ARGS(FTH_INTEGER_P(size), size, FTH_ARG1, "an integer");
610 len = FTH_INT_REF(size);
611 s = make_string_len(len);
612 memset(s->data, init, (size_t) len);
613 ficlStackPushFTH(vm->dataStack, make_string_instance(s));
614 }
615
616 static void
ficl_values_to_string(ficlVm * vm)617 ficl_values_to_string(ficlVm *vm)
618 {
619 #define h_values_to_string "( len-vals len -- str ) return string\n\
620 0 1 2 \" foo \" \"b\" \"a\" \"r\" 7 >string => \"012 foo bar\"\n\
621 Return new string with LEN objects from stack converted to their \
622 string representation. \
623 Raise an OUT-OF-RANGE exception if LEN < 0."
624 ficlInteger i, len;
625 FTH fs, obj;
626
627 FTH_STACK_CHECK(vm, 1, 0);
628 len = ficlStackPopInteger(vm->dataStack);
629
630 if (len < 0)
631 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "negative");
632
633 if (len > MAX_SEQ_LENGTH)
634 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
635
636 FTH_STACK_CHECK(vm, len, 1);
637 fs = fth_make_empty_string();
638
639 for (i = 0; i < len; i++) {
640 obj = fth_pop_ficl_cell(vm);
641 fth_string_unshift(fs, fth_object_to_string(obj));
642 }
643
644 ficlStackPushFTH(vm->dataStack, fs);
645 }
646
647 static void
ficl_make_empty_string(ficlVm * vm)648 ficl_make_empty_string(ficlVm *vm)
649 {
650 #define h_empty_string "( -- str ) return empty string\n\
651 \"\" value s1\n\
652 s1 \"aa\" string-push => \"aa\"\n\
653 s1 \"bb\" string-push => \"aabb\"\n\
654 s1 \"cc\" string-push => \"aabbcc\"\n\
655 s1 => \"aabbcc\"\n\
656 Return empty string object."
657 FTH_STACK_CHECK(vm, 0, 1);
658 push_cstring(vm, "");
659 }
660
661 static void
ficl_space_string(ficlVm * vm)662 ficl_space_string(ficlVm *vm)
663 {
664 #define h_space_string "( -- str ) return space string\n\
665 $space => \" \"\n\
666 Return string object of one space."
667 FTH_STACK_CHECK(vm, 0, 1);
668 push_cstring(vm, " ");
669 }
670
671 static void
ficl_spaces_string(ficlVm * vm)672 ficl_spaces_string(ficlVm *vm)
673 {
674 #define h_spaces_string "( len -- str ) return spaces string\n\
675 3 $spaces => \" \"\n\
676 0 $spaces => \"\"\n\
677 Return string object of LEN spaces. \
678 Raise an OUT-OF-RANGE exception if LEN < 0."
679 ficlInteger len;
680 FTH fs;
681
682 FTH_STACK_CHECK(vm, 1, 1);
683 len = ficlStackPopInteger(vm->dataStack);
684
685 if (len < 0)
686 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "negative");
687
688 if (len > MAX_SEQ_LENGTH)
689 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
690
691 if (len == 0) {
692 ficlStackPushFTH(vm->dataStack, fth_make_empty_string());
693 return;
694 }
695 fs = fth_make_string_format("%*c", (int) len, ' ');
696 ficlStackPushFTH(vm->dataStack, fs);
697 }
698
699 static void
ficl_cr_string(ficlVm * vm)700 ficl_cr_string(ficlVm *vm)
701 {
702 #define h_cr_string "( -- str ) return cr string\n\
703 $cr => \"\\n\"\n\
704 Return carriage return string object."
705 FTH_STACK_CHECK(vm, 0, 1);
706 push_cstring(vm, "\n");
707 }
708
709 static FTH
ficl_fth_format(FTH fmt,FTH args)710 ficl_fth_format(FTH fmt, FTH args)
711 {
712 #define h_fth_format "( fmt :optional args -- str ) return string\n\
713 \"hello\" fth-format => \"hello\"\n\
714 \"hello %s %d times\\n\" #( \"pumpkin\" 10 ) fth-format\n\
715 => \"hello pumpkin 10 times\\n\"\n\
716 Return string object from printf(3) FMT string and ARGS \
717 array containing corresponding arguments; ARGS is optional.\n\
718 See string-format for FMT description."
719 if (FTH_UNDEF_P(args))
720 return (fmt);
721 return (fth_string_format(fmt, args));
722 }
723
724 static void
ficl_fth_print(FTH fmt,FTH args)725 ficl_fth_print(FTH fmt, FTH args)
726 {
727 #define h_fth_print "( fmt :optional args -- ) print string\n\
728 \"hello\" fth-print => prints hello\n\
729 \"hello %s %d times\" #( \"pumpkin\" 10 ) fth-print\n\
730 => hello pumpkin 10 times\n\
731 Print FMT string with corresponding ARGS array to current stdout; \
732 ARGS is optional."
733 fth_printf("%S", ficl_fth_format(fmt, args));
734 }
735
736 static void
ficl_fth_warning(FTH fmt,FTH args)737 ficl_fth_warning(FTH fmt, FTH args)
738 {
739 #define h_fth_warning "( fmt :optional args -- ) print string\n\
740 \"%d does not fit\" #( 3 ) fth-warning => #<warning: 3 does not fit>\n\
741 Print FMT string with corresponding ARGS array \
742 wrapped in #<warning: ...> to current stderr; \
743 ARGS is optional."
744 fth_warning("%S", ficl_fth_format(fmt, args));
745 }
746
747 static void
ficl_fth_error(FTH fmt,FTH args)748 ficl_fth_error(FTH fmt, FTH args)
749 {
750 #define h_fth_error "( fmt :optional args -- ) print formatted string\n\
751 \"%d does not fit\" #( 3 ) fth-error => #<error: 3 does not fit>\n\
752 Print FMT string with corresponding ARGS array wrapped in #<error: ...> \
753 to current stderr and throw exception; ARGS is optional."
754 fth_errorf("#<error: %S>\n", ficl_fth_format(fmt, args));
755 ficlVmThrow(FTH_FICL_VM(), FICL_VM_STATUS_ERROR_EXIT);
756 }
757
758 static void
ficl_fth_die(FTH fmt,FTH args)759 ficl_fth_die(FTH fmt, FTH args)
760 {
761 #define h_fth_die "( fmt :optional args -- ) print string and exit\n\
762 \"%d does not fit\" #( 3 ) fth-die => #<die: 3 does not fit>\n\
763 Print FMT string with corresponding ARGS array wrapped in #<die: ...> \
764 to current stderr and exit interpreter with return code 1; ARGS is optional."
765 fth_errorf("#<die: %S>\n", ficl_fth_format(fmt, args));
766 fth_exit(EXIT_FAILURE);
767 }
768
769 static void
ficl_warning(ficlVm * vm)770 ficl_warning(ficlVm *vm)
771 {
772 #define h_warning "( str -- ) print warning string\n\
773 \"trouble\" warning => #<warning: trouble>\n\
774 Print STR wrapped in #<warning: ...> to current stderr."
775 FTH_STACK_CHECK(vm, 1, 0);
776 ficl_fth_warning(fth_pop_ficl_cell(vm), FTH_UNDEF);
777 }
778
779 static void
ficl_error(ficlVm * vm)780 ficl_error(ficlVm *vm)
781 {
782 #define h_error "( str -- ) print error string\n\
783 \"trouble\" error => #<error: trouble>\n\
784 Print STR wrapped in #<error: ...> to current stderr and throw exception."
785 FTH_STACK_CHECK(vm, 1, 0);
786 ficl_fth_error(fth_pop_ficl_cell(vm), FTH_UNDEF);
787 }
788
789 static void
ficl_die(ficlVm * vm)790 ficl_die(ficlVm *vm)
791 {
792 #define h_die "( str -- ) print string and exit\n\
793 \"trouble\" die => #<die: trouble>\n\
794 Print STR wrapped in #<die: ...> to current stderr \
795 and exit interpreter with return code 1."
796 FTH_STACK_CHECK(vm, 1, 0);
797 ficl_fth_die(fth_pop_ficl_cell(vm), FTH_UNDEF);
798 }
799
800 static void
ficl_print_object(ficlVm * vm)801 ficl_print_object(ficlVm *vm)
802 {
803 #define h_print_object "( obj -- ) print OBJ\n\
804 #{ 'foo 10 } .string => #{ 'foo => 10 }\n\
805 #{ 'foo 10 } .$ => #{ 'foo => 10 }\n\
806 #{ 'foo 10 } .g => #{ 'foo => 10 }\n\
807 Print string representation of OBJ to current output."
808 FTH_STACK_CHECK(vm, 1, 0);
809 fth_print(fth_to_c_string(fth_pop_ficl_cell(vm)));
810 }
811
812 static void
ficl_error_object(ficlVm * vm)813 ficl_error_object(ficlVm *vm)
814 {
815 #define h_error_object "( obj -- ) print OBJ\n\
816 #{ 'foo 10 } .error => #{ 'foo => 10 }\n\
817 Print string representation of OBJ to current error output."
818 FTH_STACK_CHECK(vm, 1, 0);
819 fth_error(fth_to_c_string(fth_pop_ficl_cell(vm)));
820 }
821
822 static void
ficl_print_stdout(ficlVm * vm)823 ficl_print_stdout(ficlVm *vm)
824 {
825 #define h_print_stdout "( obj -- ) print OBJ\n\
826 #{ 'foo 10 } .stdout => #{ 'foo => 10 }\n\
827 Print string representation of OBJ to stdout.\n\
828 See also .stderr."
829 FTH_STACK_CHECK(vm, 1, 0);
830 fth_fprintf(stdout, "%S", fth_pop_ficl_cell(vm));
831 fflush(stdout);
832 }
833
834 static void
ficl_print_stderr(ficlVm * vm)835 ficl_print_stderr(ficlVm *vm)
836 {
837 #define h_print_stderr "( obj -- ) print OBJ\n\
838 #{ 'foo 10 } .stderr => #{ 'foo => 10 }\n\
839 Print string representation of OBJ to stderr.\n\
840 See also .stdout."
841 FTH_STACK_CHECK(vm, 1, 0);
842 fth_fprintf(stderr, "%S", fth_pop_ficl_cell(vm));
843 }
844
845 static void
ficl_print_debug(ficlVm * vm)846 ficl_print_debug(ficlVm *vm)
847 {
848 #define h_print_debug "( obj -- ) print OBJ\n\
849 #{ 'foo 10 } .debug => #<DEBUG(F): #{ 'foo => 10 }>\n\
850 Print string representation of OBJ wrapped in #<DEBUG(F): ...> to stderr.\n\
851 See also .stdout and .stderr."
852 FTH_STACK_CHECK(vm, 1, 0);
853 fth_fprintf(stderr, "#<DEBUG(F): %M>\n", fth_pop_ficl_cell(vm));
854 }
855
856 /*-
857 * Compare two strings with strcmp(3) and return 1 for equal and
858 * 0 for not equal (not -1 0 1 like strcmp).
859 *
860 * FTH s1 = fth_make_string("foo");
861 * FTH s2 = fth_make_string("bar");
862 * FTH s3 = fth_make_string("foo");
863 * fth_string_equal_p(s1, s2); => 0
864 * fth_string_equal_p(s1, s3); => 1
865 * fth_string_equal_p(s3, s3); => 1
866 */
867 int
fth_string_equal_p(FTH obj1,FTH obj2)868 fth_string_equal_p(FTH obj1, FTH obj2)
869 {
870 char *b, *o;
871
872 if (!FTH_STRING_P(obj1) || !FTH_STRING_P(obj2))
873 return (0);
874
875 b = FTH_STRING_DATA(obj1);
876 o = FTH_STRING_DATA(obj2);
877 return (strcmp(b, o) == 0);
878 }
879
880 static void
ficl_string_cmp(ficlVm * vm)881 ficl_string_cmp(ficlVm *vm)
882 {
883 #define h_string_cmp "( str1 str2 -- n ) compare strings\n\
884 \"foo\" value s1\n\
885 \"bar\" value s2\n\
886 \"foo\" value s3\n\
887 s1 s2 string-cmp => 1\n\
888 s1 s3 string-cmp => 0\n\
889 s2 s3 string-cmp => -1\n\
890 Return -1 if STR1 is less than STR2, \
891 1 if STR1 is greater than STR2, \
892 and 0 if STR1 is equal to STR2. \
893 It may be used with sort functions.\n\
894 See also string=, string<>, string<, string>."
895 char *s1, *s2;
896 int n;
897
898 FTH_STACK_CHECK(vm, 2, 1);
899 s2 = pop_cstring(vm);
900 s1 = pop_cstring(vm);
901
902 if (s1 == NULL)
903 s1 = "";
904
905 if (s2 == NULL)
906 s2 = "";
907
908 n = strcmp(s1, s2);
909
910 if (n < 0)
911 ficlStackPushInteger(vm->dataStack, -1);
912 else if (n > 0)
913 ficlStackPushInteger(vm->dataStack, 1);
914 else
915 ficlStackPushInteger(vm->dataStack, 0);
916 }
917
918 static void
ficl_string_equal_p(ficlVm * vm)919 ficl_string_equal_p(ficlVm *vm)
920 {
921 #define h_string_equal_p "( str1 str2 -- f ) compare strings\n\
922 \"foo\" value s1\n\
923 \"bar\" value s2\n\
924 \"foo\" value s3\n\
925 s1 s2 string= => #f\n\
926 s1 s3 string= => #t\n\
927 s3 s3 string= => #t\n\
928 Return #t if strings are equal, otherwise #f.\n\
929 See also string<>, string<, string>, string-cmp."
930 FTH obj1, obj2;
931
932 FTH_STACK_CHECK(vm, 2, 1);
933 obj2 = fth_pop_ficl_cell(vm);
934 obj1 = fth_pop_ficl_cell(vm);
935 ficlStackPushBoolean(vm->dataStack, fth_string_equal_p(obj1, obj2));
936 }
937
938 /*-
939 * Compare two strings with strcmp(3) and return 1 for not equal
940 * and 0 for equal (not -1 0 1 like strcmp).
941 *
942 * FTH s1 = fth_make_string("foo");
943 * FTH s2 = fth_make_string("bar");
944 * FTH s3 = fth_make_string("foo");
945 * fth_string_not_equal_p(s1, s2); => 1
946 * fth_string_not_equal_p(s1, s3); => 0
947 * fth_string_not_equal_p(s3, s3); => 0
948 */
949 int
fth_string_not_equal_p(FTH obj1,FTH obj2)950 fth_string_not_equal_p(FTH obj1, FTH obj2)
951 {
952 char *b, *o;
953
954 if (!FTH_STRING_P(obj1) || !FTH_STRING_P(obj2))
955 return (0);
956
957 b = FTH_STRING_DATA(obj1);
958 o = FTH_STRING_DATA(obj2);
959 return (strcmp(b, o) != 0);
960 }
961
962 static void
ficl_string_not_equal_p(ficlVm * vm)963 ficl_string_not_equal_p(ficlVm *vm)
964 {
965 #define h_string_not_equal_p "( str1 str2 -- f ) compare strings\n\
966 \"foo\" value s1\n\
967 \"bar\" value s2\n\
968 \"foo\" value s3\n\
969 s1 s2 string<> => #t\n\
970 s1 s3 string<> => #f\n\
971 s3 s3 string<> => #f\n\
972 Return #t if strings are not equal, otherwise #f.\n\
973 See also string=, string<, string>, string-cmp."
974 FTH obj1, obj2;
975
976 FTH_STACK_CHECK(vm, 2, 1);
977 obj2 = fth_pop_ficl_cell(vm);
978 obj1 = fth_pop_ficl_cell(vm);
979 ficlStackPushBoolean(vm->dataStack, fth_string_not_equal_p(obj1, obj2));
980 }
981
982 /*-
983 * Compare two strings with strcmp(3) and return 1 for less than and
984 * 0 for equal or greater than.
985 *
986 * FTH s1 = fth_make_string("foo");
987 * FTH s2 = fth_make_string("bar");
988 * FTH s3 = fth_make_string("foo");
989 * fth_string_less_p(s1, s2); => 0
990 * fth_string_less_p(s1, s3); => 0
991 * fth_string_less_p(s3, s3); => 0
992 */
993 int
fth_string_less_p(FTH obj1,FTH obj2)994 fth_string_less_p(FTH obj1, FTH obj2)
995 {
996 char *b, *o;
997
998 if (!FTH_STRING_P(obj1) || !FTH_STRING_P(obj2))
999 return (0);
1000
1001 b = FTH_STRING_DATA(obj1);
1002 o = FTH_STRING_DATA(obj2);
1003 return (strcmp(b, o) < 0);
1004 }
1005
1006 static void
ficl_string_less_p(ficlVm * vm)1007 ficl_string_less_p(ficlVm *vm)
1008 {
1009 #define h_string_less_p "( str1 str2 -- f ) compare strings\n\
1010 \"foo\" value s1\n\
1011 \"bar\" value s2\n\
1012 \"foo\" value s3\n\
1013 s1 s2 string< => #f\n\
1014 s1 s3 string< => #f\n\
1015 s3 s3 string< => #f\n\
1016 Return #t if STR1 is lexicographically lesser than STR2, otherwise #f.\n\
1017 See also string=, string<>, string>, string-cmp."
1018 FTH obj1, obj2;
1019
1020 FTH_STACK_CHECK(vm, 2, 1);
1021 obj2 = fth_pop_ficl_cell(vm);
1022 obj1 = fth_pop_ficl_cell(vm);
1023 ficlStackPushBoolean(vm->dataStack, fth_string_less_p(obj1, obj2));
1024 }
1025
1026 /*-
1027 * Compare two strings with strcmp(3) and return 1 for greater than and
1028 * 0 for equal or less than.
1029 *
1030 * FTH s1 = fth_make_string("foo");
1031 * FTH s2 = fth_make_string("bar");
1032 * FTH s3 = fth_make_string("foo");
1033 * fth_string_greater_p(s1, s2); => 1
1034 * fth_string_greater_p(s1, s3); => 0
1035 * fth_string_greater_p(s3, s3); => 0
1036 */
1037 int
fth_string_greater_p(FTH obj1,FTH obj2)1038 fth_string_greater_p(FTH obj1, FTH obj2)
1039 {
1040 char *b, *o;
1041
1042 if (!FTH_STRING_P(obj1) || !FTH_STRING_P(obj2))
1043 return (0);
1044
1045 b = FTH_STRING_DATA(obj1);
1046 o = FTH_STRING_DATA(obj2);
1047 return (strcmp(b, o) > 0);
1048 }
1049
1050 static void
ficl_string_greater_p(ficlVm * vm)1051 ficl_string_greater_p(ficlVm *vm)
1052 {
1053 #define h_string_greater_p "( str1 str2 -- f ) compare strings\n\
1054 \"foo\" value s1\n\
1055 \"bar\" value s2\n\
1056 \"foo\" value s3\n\
1057 s1 s2 string> => #t\n\
1058 s1 s3 string> => #f\n\
1059 s3 s3 string> => #f\n\
1060 Return #t if STR1 is lexicographically greater than STR2, otherwise #f.\n\
1061 See also string=, string<>, string<, string-cmp."
1062 FTH obj1, obj2;
1063
1064 FTH_STACK_CHECK(vm, 2, 1);
1065 obj2 = fth_pop_ficl_cell(vm);
1066 obj1 = fth_pop_ficl_cell(vm);
1067 ficlStackPushBoolean(vm->dataStack, fth_string_greater_p(obj1, obj2));
1068 }
1069
1070 /*-
1071 * FTH fs = fth_make_string("foo");
1072 * fth_string_to_array(fs); => #( 102 111 111 )
1073 */
1074 FTH
fth_string_to_array(FTH fs)1075 fth_string_to_array(FTH fs)
1076 {
1077 #define h_str_to_ary "( str -- ary ) return array\n\
1078 \"foo\" string->array => #( 102 111 111 )\n\
1079 Convert STR to an array of characters."
1080 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1081 return (str_to_array(fs));
1082 }
1083
1084 /*-
1085 * Return a new copy of the Fth string object.
1086 *
1087 * FTH s1 = fth_make_string("foo");
1088 * FTH s2 = fth_string_copy(s1);
1089 * s1 == s2 => 0
1090 * fth_string_equal_p(s1, s2); => 1
1091 */
1092 FTH
fth_string_copy(FTH fs)1093 fth_string_copy(FTH fs)
1094 {
1095 #define h_string_copy "( str1 -- str2 ) duplicate string\n\
1096 \"foo\" value s1\n\
1097 s1 string-copy value s2\n\
1098 s1 string-reverse! drop\n\
1099 s1 => \"oof\"\n\
1100 s2 => \"foo\"\n\
1101 Return copy of STR1."
1102 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1103 return (str_to_string(fs));
1104 }
1105
1106 /*-
1107 * FTH fs = fth_make_string("foo");
1108 * char c = fth_string_c_char_ref(fs, 1); => 'o' (111)
1109 */
1110 char
fth_string_c_char_ref(FTH fs,ficlInteger idx)1111 fth_string_c_char_ref(FTH fs, ficlInteger idx)
1112 {
1113 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1114
1115 if (idx < 0)
1116 idx += FTH_STRING_LENGTH(fs);
1117
1118 if (idx < 0 || idx >= FTH_STRING_LENGTH(fs))
1119 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
1120
1121 return (FTH_STRING_DATA(fs)[idx]);
1122 }
1123
1124 /* Dangerous! No check for string or string bounds. */
1125 char
fth_string_c_char_fast_ref(FTH fs,ficlInteger idx)1126 fth_string_c_char_fast_ref(FTH fs, ficlInteger idx)
1127 {
1128 return (FTH_STRING_DATA(fs)[idx]);
1129 }
1130
1131 /*-
1132 * FTH fs = fth_make_string("foo");
1133 * FTH ch = fth_string_char_ref(fs, 1); => 111
1134 */
1135 FTH
fth_string_char_ref(FTH fs,ficlInteger idx)1136 fth_string_char_ref(FTH fs, ficlInteger idx)
1137 {
1138 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1139
1140 if (idx < 0)
1141 idx += FTH_STRING_LENGTH(fs);
1142
1143 return (str_ref(fs, fth_make_int(idx)));
1144 }
1145
1146 static void
ficl_string_ref(ficlVm * vm)1147 ficl_string_ref(ficlVm *vm)
1148 {
1149 #define h_string_ref "( string idx -- value ) return char\n\
1150 \"foo\" 1 string-ref => 111\n\
1151 Return character at position IDX; negative index counts from backward. \
1152 Raise an OUT-OF-RANGE exception if index is not in range of string."
1153 ficlInteger idx;
1154 FTH string;
1155
1156 FTH_STACK_CHECK(vm, 2, 1);
1157 idx = ficlStackPopInteger(vm->dataStack);
1158 string = fth_pop_ficl_cell(vm);
1159 fth_push_ficl_cell(vm, fth_string_char_ref(string, idx));
1160 }
1161
1162 /*-
1163 * FTH fs = fth_make_string("foo");
1164 * fth_string_c_char_set(fs, 1, 'e'); => 101
1165 * fth_printf("%S", fs); => "feo"
1166 */
1167 char
fth_string_c_char_set(FTH fs,ficlInteger idx,char c)1168 fth_string_c_char_set(FTH fs, ficlInteger idx, char c)
1169 {
1170 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1171
1172 if (idx < 0)
1173 idx += FTH_STRING_LENGTH(fs);
1174
1175 if (idx < 0 || idx >= FTH_STRING_LENGTH(fs))
1176 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
1177
1178 FTH_INSTANCE_CHANGED(fs);
1179 return (FTH_STRING_DATA(fs)[idx] = c);
1180 }
1181
1182 /* Dangerous! No check for string or string bounds. */
1183 char
fth_string_c_char_fast_set(FTH fs,ficlInteger idx,char c)1184 fth_string_c_char_fast_set(FTH fs, ficlInteger idx, char c)
1185 {
1186 FTH_INSTANCE_CHANGED(fs);
1187 return (FTH_STRING_DATA(fs)[idx] = c);
1188 }
1189
1190 /*-
1191 * FTH fs = fth_make_string("foo");
1192 * fth_string_char_set(fs, 1, CHAR_TO_FTH('e')); => 101
1193 * fth_printf("%S", fs); => "feo"
1194 */
1195 FTH
fth_string_char_set(FTH fs,ficlInteger idx,FTH value)1196 fth_string_char_set(FTH fs, ficlInteger idx, FTH value)
1197 {
1198 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1199
1200 if (idx < 0)
1201 idx += FTH_STRING_LENGTH(fs);
1202
1203 return (str_set(fs, fth_make_int(idx), value));
1204 }
1205
1206 static void
ficl_string_set(ficlVm * vm)1207 ficl_string_set(ficlVm *vm)
1208 {
1209 #define h_string_set "( string idx char -- ) set CHAR\n\
1210 \"foo\" value s1\n\
1211 s1 1 <char> e string-set!\n\
1212 s1 => \"feo\"\n\
1213 Store character CHAR at index IDX; negative index counts from backward. \
1214 Raise an OUT-OF-RANGE exception if index is not in range of string."
1215 ficlInteger idx;
1216 FTH string, value;
1217
1218 FTH_STACK_CHECK(vm, 3, 0);
1219 value = fth_pop_ficl_cell(vm);
1220 idx = ficlStackPopInteger(vm->dataStack);
1221 string = fth_pop_ficl_cell(vm);
1222 fth_string_char_set(string, idx, value);
1223 }
1224
1225 /*-
1226 * FTH fs = fth_make_string("foo");
1227 * fth_string_push(fs, fth_make_string(" ")); => "foo "
1228 * fth_string_push(fs, INT_TO_FIX(10)); => "foo 10"
1229 */
1230 FTH
fth_string_push(FTH fs,FTH add)1231 fth_string_push(FTH fs, FTH add)
1232 {
1233 #define h_string_push "( string value -- string' ) add to STRING\n\
1234 \"foo\" value s1\n\
1235 s1 $space string-push drop\n\
1236 s1 10 string-push drop\n\
1237 s1 => \"foo 10\"\n\
1238 Append string representation of VALUE to STRING \
1239 and return changed string object.\n\
1240 See also string-pop, string-unshift, string-shift."
1241 ficlInteger new_buf_len, l, sl, al;
1242 size_t st;
1243 char *b;
1244
1245 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1246
1247 if (!FTH_STRING_P(add))
1248 add = fth_object_to_string(add);
1249
1250 if (FTH_STRING_LENGTH(add) == 0)
1251 return (fs);
1252
1253 sl = FTH_STRING_LENGTH(fs);
1254 al = FTH_STRING_LENGTH(add);
1255 new_buf_len = FTH_STRING_TOP(fs) + sl + al + 1;
1256
1257 if (new_buf_len > FTH_STRING_BUF_LENGTH(fs)) {
1258 l = NEW_SEQ_LENGTH(new_buf_len);
1259
1260 if (l > MAX_SEQ_LENGTH)
1261 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, l, "too long");
1262
1263 FTH_STRING_BUF_LENGTH(fs) = l;
1264 st = (size_t) l;
1265 FTH_STRING_BUF(fs) = FTH_REALLOC(FTH_STRING_BUF(fs), st);
1266 FTH_STRING_DATA(fs) = FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
1267 }
1268 st = (size_t) FTH_STRING_LENGTH(add);
1269 b = FTH_STRING_DATA(add);
1270 memmove(FTH_STRING_DATA(fs) + sl, b, st);
1271 FTH_STRING_LENGTH(fs) += al;
1272 FTH_STRING_DATA(fs)[FTH_STRING_LENGTH(fs)] = '\0';
1273 FTH_INSTANCE_CHANGED(fs);
1274 return (fs);
1275 }
1276
1277 /*-
1278 * FTH fs = fth_make_string("foo");
1279 * fth_string_pop(fs); => 111 ('o')
1280 * fth_string_pop(fs); => 111 ('o')
1281 * fth_string_pop(fs); => 102 ('f')
1282 * fth_string_pop(fs); => #f
1283 */
1284 FTH
fth_string_pop(FTH fs)1285 fth_string_pop(FTH fs)
1286 {
1287 #define h_string_pop "( string -- char ) return last char\n\
1288 \"foo\" value s1\n\
1289 s1 string-pop => 111\n\
1290 s1 string-pop => 111\n\
1291 s1 string-pop => 102\n\
1292 s1 string-pop => #f\n\
1293 Remove and return last character. \
1294 If STR is empty, return #f.\n\
1295 See also string-push, string-unshift, string-shift."
1296 ficlInteger l;
1297 FTH c;
1298
1299 c = FTH_FALSE;
1300 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1301
1302 if (FTH_STRING_LENGTH(fs) == 0)
1303 return (c);
1304
1305 /* - 1 (length--) + 1 ('\0') */
1306 l = NEW_SEQ_LENGTH(FTH_STRING_TOP(fs) + FTH_STRING_LENGTH(fs));
1307 FTH_STRING_LENGTH(fs)--;
1308 c = CHAR_TO_FTH(FTH_STRING_DATA(fs)[FTH_STRING_LENGTH(fs)]);
1309 FTH_STRING_DATA(fs)[FTH_STRING_LENGTH(fs)] = '\0';
1310
1311 if (l < FTH_STRING_BUF_LENGTH(fs)) {
1312 FTH_STRING_BUF_LENGTH(fs) = l;
1313 FTH_STRING_BUF(fs) = FTH_REALLOC(FTH_STRING_BUF(fs), (size_t)l);
1314 FTH_STRING_DATA(fs) = FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
1315 }
1316 FTH_INSTANCE_CHANGED(fs);
1317 return (c);
1318 }
1319
1320 /*-
1321 * FTH fs = fth_make_string("foo");
1322 * fth_string_unshift(fs, fth_make_string(" ")); => " foo"
1323 * fth_string_unshift(fs, INT_TO_FIX(10)); => "10 foo"
1324 */
1325 FTH
fth_string_unshift(FTH fs,FTH add)1326 fth_string_unshift(FTH fs, FTH add)
1327 {
1328 #define h_str_unshift "( string value -- string' ) prepend to STRING\n\
1329 \"foo\" value s1\n\
1330 s1 $space string-unshift drop\n\
1331 s1 10 string-unshift drop\n\
1332 s1 => \"10 foo\"\n\
1333 Prepend string representation of VALUE to STRING \
1334 and return changed string object.\n\
1335 See also string-push, string-pop, string-shift."
1336 ficlInteger l , new_top, new_len, new_buf_len, al;
1337 char *b;
1338 size_t st;
1339
1340 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1341
1342 if (!FTH_STRING_P(add))
1343 add = fth_object_to_string(add);
1344
1345 if (FTH_STRING_LENGTH(add) == 0)
1346 return (fs);
1347
1348 al = FTH_STRING_LENGTH(add);
1349 new_top = FTH_STRING_TOP(fs) - al;
1350 new_len = FTH_STRING_LENGTH(fs) + al;
1351 new_buf_len = new_top + new_len + 1;
1352
1353 if (new_top < 1) {
1354 new_top = FTH_STRING_BUF_LENGTH(fs) / 3;
1355 new_buf_len = new_top + new_len + 1;
1356
1357 if (new_buf_len > FTH_STRING_BUF_LENGTH(fs)) {
1358 l = NEW_SEQ_LENGTH(new_buf_len);
1359
1360 if (l > MAX_SEQ_LENGTH)
1361 FTH_OUT_OF_BOUNDS_ERROR(1, l, "too long");
1362 FTH_STRING_BUF_LENGTH(fs) = l;
1363 st = (size_t) l;
1364 FTH_STRING_BUF(fs) =
1365 FTH_REALLOC(FTH_STRING_BUF(fs), st);
1366 FTH_STRING_DATA(fs) =
1367 FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
1368 }
1369 b = FTH_STRING_DATA(fs);
1370 st = (size_t) FTH_STRING_LENGTH(fs);
1371 memmove(FTH_STRING_BUF(fs) + new_top + al, b, st);
1372 } else if (new_buf_len > FTH_STRING_BUF_LENGTH(fs)) {
1373 l = NEW_SEQ_LENGTH(new_buf_len);
1374
1375 if (l > MAX_SEQ_LENGTH)
1376 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, l, "too long");
1377
1378 FTH_STRING_BUF_LENGTH(fs) = l;
1379 st = (size_t) l;
1380 FTH_STRING_BUF(fs) = FTH_REALLOC(FTH_STRING_BUF(fs), st);
1381 FTH_STRING_DATA(fs) = FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
1382 }
1383 FTH_STRING_TOP(fs) = new_top;
1384 FTH_STRING_LENGTH(fs) = new_len;
1385 b = FTH_STRING_DATA(add);
1386 st = (size_t) al;
1387 memmove(FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs), b, st);
1388 FTH_STRING_DATA(fs) = FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
1389 FTH_STRING_DATA(fs)[FTH_STRING_LENGTH(fs)] = '\0';
1390 FTH_INSTANCE_CHANGED(fs);
1391 return (fs);
1392 }
1393
1394 /*-
1395 * FTH fs = fth_make_string("foo");
1396 * fth_string_shift(fs); => 102 ('f')
1397 * fth_string_shift(fs); => 111 ('o')
1398 * fth_string_shift(fs); => 111 ('o')
1399 * fth_string_shift(fs); => #f
1400 */
1401 FTH
fth_string_shift(FTH fs)1402 fth_string_shift(FTH fs)
1403 {
1404 #define h_string_shift "( string -- char ) return first char\n\
1405 \"foo\" value s1\n\
1406 s1 string-shift => 102\n\
1407 s1 string-shift => 111\n\
1408 s1 string-shift => 111\n\
1409 s1 string-shift => #f\n\
1410 Remove and return first character. \
1411 If STR is empty, return #f.\n\
1412 See also string-push, string-pop, string-unshift."
1413 ficlInteger l;
1414 size_t st;
1415 char *b;
1416 FTH c;
1417
1418 c = FTH_FALSE;
1419 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1420
1421 if (FTH_STRING_LENGTH(fs) == 0)
1422 return (c);
1423
1424 b = FTH_STRING_DATA(fs);
1425 c = CHAR_TO_FTH(b[0]);
1426
1427 if ((FTH_STRING_TOP(fs) + 1) > (FTH_STRING_BUF_LENGTH(fs) / 2)) {
1428 FTH_STRING_TOP(fs) = FTH_STRING_BUF_LENGTH(fs) / 3;
1429 st = (size_t) FTH_STRING_LENGTH(fs);
1430 memmove(FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs), b, st);
1431 }
1432 /* - 1 (length--) + 1 ('\0') */
1433 l = NEW_SEQ_LENGTH(FTH_STRING_TOP(fs) + FTH_STRING_LENGTH(fs));
1434 FTH_STRING_LENGTH(fs)--;
1435 FTH_STRING_TOP(fs)++;
1436
1437 if (l < FTH_STRING_BUF_LENGTH(fs)) {
1438 FTH_STRING_BUF_LENGTH(fs) = l;
1439 st = (size_t) l;
1440 FTH_STRING_BUF(fs) = FTH_REALLOC(FTH_STRING_BUF(fs), st);
1441 }
1442 FTH_STRING_DATA(fs) = FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
1443 FTH_INSTANCE_CHANGED(fs);
1444 return (c);
1445 }
1446
1447 /*-
1448 * FTH s1 = fth_make_string("foo");
1449 * FTH s2 = fth_make_string("bar");
1450 * fth_string_append(s1, s2); => "foobar"
1451 */
1452 FTH
fth_string_append(FTH fs1,FTH fs2)1453 fth_string_append(FTH fs1, FTH fs2)
1454 {
1455 #define h_string_append "( str1 str2 -- str3 ) return string STR1+STR2\n\
1456 \"foo\" value s1\n\
1457 \"bar\" value s2\n\
1458 s1 s2 string-append value s3\n\
1459 s1 => \"foo\"\n\
1460 s2 => \"bar\"\n\
1461 s3 => \"foobar\"\n\
1462 Return new string from STR1+STR2.\n\
1463 See also string-concat and string-push."
1464 char *b1, *b2;
1465
1466 FTH_ASSERT_ARGS(FTH_STRING_P(fs1), fs1, FTH_ARG1, "a string");
1467 FTH_ASSERT_ARGS(FTH_STRING_P(fs2), fs2, FTH_ARG2, "a string");
1468 b1 = FTH_STRING_DATA(fs1);
1469 b2 = FTH_STRING_DATA(fs2);
1470 return (fth_make_string_format("%s%s", b1, b2));
1471 }
1472
1473 /*-
1474 * FTH fs = fth_make_string("foo");
1475 * fth_string_reverse(fs); => "oof"
1476 */
1477 FTH
fth_string_reverse(FTH fs)1478 fth_string_reverse(FTH fs)
1479 {
1480 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1481 ficlStringReverse(FTH_STRING_REF(fs));
1482 FTH_INSTANCE_CHANGED(fs);
1483 return (fs);
1484 }
1485
1486 static void
ficl_string_reverse(ficlVm * vm)1487 ficl_string_reverse(ficlVm *vm)
1488 {
1489 #define h_string_reverse "( str1 -- str2 ) reverse string\n\
1490 \"foo\" value s1\n\
1491 s1 string-reverse value s2\n\
1492 s1 => \"foo\"\n\
1493 s2 => \"oof\"\n\
1494 Return STR1 reversed as new string object.\n\
1495 See also string-reverse!."
1496 FTH fs;
1497
1498 FTH_STACK_CHECK(vm, 1, 1);
1499 fs = fth_string_copy(fth_pop_ficl_cell(vm));
1500 ficlStackPushFTH(vm->dataStack, fth_string_reverse(fs));
1501 }
1502
1503 static void
ficl_string_reverse_bang(ficlVm * vm)1504 ficl_string_reverse_bang(ficlVm *vm)
1505 {
1506 #define h_str_rev_bang "( str -- str' ) reverse string\n\
1507 \"foo\" value s1\n\
1508 s1 string-reverse! drop\n\
1509 s1 => \"oof\"\n\
1510 Return the same string object STR reversed.\n\
1511 See also string-reverse."
1512 FTH fs;
1513
1514 FTH_STACK_CHECK(vm, 1, 1);
1515 fs = fth_pop_ficl_cell(vm);
1516 ficlStackPushFTH(vm->dataStack, fth_string_reverse(fs));
1517 }
1518
1519 /*-
1520 * FTH fs = fth_make_string("foo");
1521 * fth_string_insert(fs, 1, INT_TO_FIX(10)); => "f10oo"
1522 */
1523 FTH
fth_string_insert(FTH fs,ficlInteger idx,FTH ins)1524 fth_string_insert(FTH fs, ficlInteger idx, FTH ins)
1525 {
1526 ficlInteger sl, il, rl, new_buf_len, l;
1527 size_t st;
1528
1529 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1530 sl = FTH_STRING_LENGTH(fs);
1531
1532 if (idx < 0)
1533 idx += sl;
1534
1535 if (idx == 0) {
1536 fth_string_unshift(fs, ins);
1537 return (fs);
1538 }
1539 if (idx < 0 || idx >= sl)
1540 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
1541
1542 if (!FTH_STRING_P(ins))
1543 ins = fth_object_to_string(ins);
1544
1545 il = FTH_STRING_LENGTH(ins);
1546
1547 if (il == 0)
1548 return (fs);
1549
1550 rl = sl + il + 1;
1551 new_buf_len = FTH_STRING_TOP(fs) + rl;
1552
1553 if (new_buf_len > FTH_STRING_BUF_LENGTH(fs)) {
1554 l = NEW_SEQ_LENGTH(new_buf_len);
1555
1556 if (l > MAX_SEQ_LENGTH)
1557 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, l, "too long");
1558
1559 FTH_STRING_BUF_LENGTH(fs) = l;
1560 st = (size_t) l;
1561 FTH_STRING_BUF(fs) = FTH_REALLOC(FTH_STRING_BUF(fs), st);
1562 FTH_STRING_DATA(fs) = FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
1563 }
1564 st = (size_t) (sl - idx);
1565 memmove(FTH_STRING_DATA(fs) + idx + il, FTH_STRING_DATA(fs) + idx, st);
1566 st = (size_t) il;
1567 memmove(FTH_STRING_DATA(fs) + idx, FTH_STRING_DATA(ins), st);
1568 FTH_STRING_LENGTH(fs) += FTH_STRING_LENGTH(ins);
1569 FTH_STRING_DATA(fs)[FTH_STRING_LENGTH(fs)] = '\0';
1570 FTH_INSTANCE_CHANGED(fs);
1571 return (fs);
1572 }
1573
1574 static void
ficl_string_insert(ficlVm * vm)1575 ficl_string_insert(ficlVm *vm)
1576 {
1577 #define h_string_insert "( string idx value -- string' ) insert element\n\
1578 \"foo\" value s1\n\
1579 s1 1 10 string-insert! drop\n\
1580 s1 => \"f10oo\"\n\
1581 Insert string representation of VALUE to STRING at position IDX; \
1582 negative index counts from backward. \
1583 Raise an OUT-OF-RANGE exception if index is not in range of string."
1584 FTH str, ins;
1585 ficlInteger idx;
1586
1587 FTH_STACK_CHECK(vm, 3, 1);
1588 ins = fth_pop_ficl_cell(vm);
1589 idx = ficlStackPopInteger(vm->dataStack);
1590 str = fth_pop_ficl_cell(vm);
1591 ficlStackPushFTH(vm->dataStack, fth_string_insert(str, idx, ins));
1592 }
1593
1594 /*-
1595 * FTH fs = fth_make_string("foo");
1596 * fth_string_delete(fs, 1); => 111 ('o')
1597 * fth_printf("%S", fs); => "fo"
1598 */
1599 FTH
fth_string_delete(FTH fs,ficlInteger idx)1600 fth_string_delete(FTH fs, ficlInteger idx)
1601 {
1602 ficlInteger l;
1603 size_t st;
1604 FTH c;
1605
1606 c = FTH_FALSE;
1607 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1608
1609 if (FTH_STRING_LENGTH(fs) == 0)
1610 return (c);
1611
1612 if (idx < 0)
1613 idx += FTH_STRING_LENGTH(fs);
1614
1615 if (idx < 0 || idx >= FTH_STRING_LENGTH(fs))
1616 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
1617
1618 if (idx == 0)
1619 return (fth_string_shift(fs));
1620
1621 if (idx == (FTH_STRING_LENGTH(fs) - 1))
1622 return (fth_string_pop(fs));
1623
1624 c = CHAR_TO_FTH(FTH_STRING_DATA(fs)[idx]);
1625 FTH_STRING_LENGTH(fs)--;
1626 l = NEW_SEQ_LENGTH(FTH_STRING_TOP(fs) + FTH_STRING_LENGTH(fs) + 1);
1627
1628 if (l < FTH_STRING_BUF_LENGTH(fs)) {
1629 FTH_STRING_BUF_LENGTH(fs) = l;
1630 st = (size_t) l;
1631 FTH_STRING_BUF(fs) = FTH_REALLOC(FTH_STRING_BUF(fs), st);
1632 FTH_STRING_DATA(fs) = FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
1633 }
1634 st = (size_t) (FTH_STRING_LENGTH(fs) - idx);
1635 memmove(FTH_STRING_DATA(fs) + idx, FTH_STRING_DATA(fs) + idx + 1, st);
1636 FTH_STRING_DATA(fs)[FTH_STRING_LENGTH(fs)] = '\0';
1637 FTH_INSTANCE_CHANGED(fs);
1638 return (c);
1639 }
1640
1641 static void
ficl_string_delete(ficlVm * vm)1642 ficl_string_delete(ficlVm *vm)
1643 {
1644 #define h_string_delete "( string idx -- char ) delete char\n\
1645 \"foo\" value s1\n\
1646 s1 1 string-delete! => 111\n\
1647 s1 => \"fo\"\n\
1648 Delete and return character at position IDX from STRING; \
1649 negative index counts from backward. \
1650 Raise an OUT-OF-RANGE exception if index is not in range of string."
1651 FTH str;
1652 ficlInteger idx;
1653
1654 FTH_STACK_CHECK(vm, 2, 1);
1655 idx = ficlStackPopInteger(vm->dataStack);
1656 str = fth_pop_ficl_cell(vm);
1657 fth_push_ficl_cell(vm, fth_string_delete(str, idx));
1658 }
1659
1660 /*-
1661 * FTH fs = fth_make_string("foo");
1662 * fth_string_fill(fs, CHAR_TO_FTH('a')); => "aaa"
1663 * fth_printf("%S", fs); => "aaa"
1664 */
1665 FTH
fth_string_fill(FTH fs,FTH fill_char)1666 fth_string_fill(FTH fs, FTH fill_char)
1667 {
1668 #define h_string_fill "( string char -- string' ) fill string\n\
1669 \"foo\" value s1\n\
1670 s1 <char> a string-fill drop\n\
1671 s1 => \"aaa\"\n\
1672 Fill STRING with CHAR and return changed string object."
1673 size_t st;
1674
1675 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1676 FTH_ASSERT_ARGS(FTH_CHAR_P(fill_char), fill_char, FTH_ARG2, "a char");
1677 st = (size_t) FTH_STRING_LENGTH(fs);
1678 memset(FTH_STRING_DATA(fs), FTH_TO_CCHAR(fill_char), st);
1679 FTH_INSTANCE_CHANGED(fs);
1680 return (fs);
1681 }
1682
1683 /*-
1684 * FTH fs = fth_make_string("hello world");
1685 * FTH rs fth_make_string("l");
1686 * fth_string_index(fs, rs); => 2
1687 * FTH rs = fth_make_string("orl");
1688 * fth_string_index(fs, rs); => 7
1689 * FTH rs = fth_make_string("k");
1690 * fth_string_index(fs, rs); => -1 (false)
1691 */
1692 FTH
fth_string_index(FTH fs,FTH key)1693 fth_string_index(FTH fs, FTH key)
1694 {
1695 #define h_string_index "( str key -- index|-1 ) find KEY\n\
1696 \"hello world\" \"l\" string-index => 2\n\
1697 \"hello world\" \"orl\" string-index => 7\n\
1698 \"hello world\" \"k\" string-index => -1\n\
1699 Return index of string KEY in STR or -1 if not found.\n\
1700 See also string-member? and string-find."
1701 char *res;
1702
1703 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1704 FTH_ASSERT_ARGS(FTH_STRING_P(key), key, FTH_ARG2, "a string");
1705 res = strstr(FTH_STRING_DATA(fs), FTH_STRING_DATA(key));
1706
1707 if (res != NULL)
1708 return (fth_make_int(res - FTH_STRING_DATA(fs)));
1709
1710 return (FTH_ONE_NEG);
1711 }
1712
1713 /*-
1714 * FTH fs = fth_make_string("hello world");
1715 * FTH rs fth_make_string("l");
1716 * fth_string_member_p(fs, rs); => 1
1717 * FTH rs = fth_make_string("ell");
1718 * fth_string_member_p(fs, rs); => 1
1719 * FTH rs = fth_make_string("k");
1720 * fth_string_member_p(fs, rs); => 0
1721 */
1722 int
fth_string_member_p(FTH fs,FTH key)1723 fth_string_member_p(FTH fs, FTH key)
1724 {
1725 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1726 FTH_ASSERT_ARGS(FTH_STRING_P(key), key, FTH_ARG2, "a string");
1727 return (strstr(FTH_STRING_DATA(fs), FTH_STRING_DATA(key)) != NULL);
1728 }
1729
1730 static void
ficl_string_member_p(ficlVm * vm)1731 ficl_string_member_p(ficlVm *vm)
1732 {
1733 #define h_string_member_p "( str key -- f ) find KEY\n\
1734 \"hello world\" \"l\" string-member? => #t\n\
1735 \"hello world\" \"ell\" string-member? => #t\n\
1736 \"hello world\" \"k\" string-member? => #f\n\
1737 Return #t if string KEY exist in STR, otherwise #f.\n\
1738 See also string-index and string-find."
1739 FTH str, key;
1740
1741 FTH_STACK_CHECK(vm, 2, 1);
1742 key = fth_pop_ficl_cell(vm);
1743 str = fth_pop_ficl_cell(vm);
1744 ficlStackPushBoolean(vm->dataStack, fth_string_member_p(str, key));
1745 }
1746
1747 /*-
1748 * FTH fs = fth_make_string("hello world");
1749 * FTH rs fth_make_string("l");
1750 * fth_string_find(fs, rs); => "llo world"
1751 * FTH rs = fth_make_string("ell");
1752 * fth_string_find(fs, rs); => "ello world"
1753 * FTH rs = fth_make_regexp("ell");
1754 * fth_string_find(fs, rs); => "ello world"
1755 * FTH rs = fth_make_regexp("k");
1756 * fth_string_find(fs, rs); => #f
1757 */
1758 FTH
fth_string_find(FTH fs,FTH key)1759 fth_string_find(FTH fs, FTH key)
1760 {
1761 #define h_string_find "( str1 key -- str2|#f ) find KEY\n\
1762 \"hello world\" \"l\" string-find => \"llo world\"\n\
1763 \"hello world\" \"ell\" string-find => \"ello world\"\n\
1764 \"hello world\" /ell/ string-find => \"ello world\"\n\
1765 \"hello world\" /k/ string-find => #f\n\
1766 Return match if string or regexp KEY exist in STR, otherwise #f.\n\
1767 See also string-index, string-member? and regexp-match."
1768 ficlInteger pos;
1769
1770 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1771 FTH_ASSERT_ARGS(FTH_STRREG_P(key), key, FTH_ARG2, "a string or regexp");
1772
1773 if (FTH_STRING_P(key)) {
1774 char *str, *k, *substr;
1775
1776 str = FTH_STRING_REF(fs);
1777 k = FTH_STRING_REF(key);
1778 substr = NULL;
1779
1780 if (str != NULL && k != NULL)
1781 substr = strstr(str, k);
1782
1783 if (substr != NULL)
1784 return (fth_make_string(substr));
1785
1786 return (FTH_FALSE);
1787 }
1788 pos = fth_regexp_search(key, fs, 0, -1);
1789
1790 if (pos == -1)
1791 return (FTH_FALSE);
1792
1793 return (fth_string_substring(fs, pos, FTH_STRING_LENGTH(fs)));
1794 }
1795
1796 /*-
1797 * FTH fs = fth_make_string("foo:bar:baz");
1798 * FTH sp = fth_make_string(":");
1799 * fth_string_split(fs, sp); => #( "foo" "bar" "baz")
1800 * FTH sp = fth_make_regexp(":");
1801 * fth_string_split(fs, sp); => #( "foo" "bar" "baz")
1802 * FTH fs = fth_make_string("foo bar baz");
1803 * fth_string_split(fs, FTH_NIL); => #( "foo" "bar" "baz")
1804 */
1805 FTH
fth_string_split(FTH fs,FTH reg)1806 fth_string_split(FTH fs, FTH reg)
1807 {
1808 #define h_string_split "( str sep -- ary ) return array\n\
1809 \"foo:bar:baz\" \":\" string-split => #( \"foo\" \"bar\" \"baz\" )\n\
1810 \"foo:bar:baz\" \"/:/\" string-split => #( \"foo\" \"bar\" \"baz\" )\n\
1811 \"foo bar baz\" nil string-split => #( \"foo\" \"bar\" \"baz\" )\n\
1812 Split STR using SEP as delimiter and return result as array of strings. \
1813 If SEP is not a string or regexp, delimiter is space."
1814 FTH result;
1815 char *delim, *p, *s, *str;
1816
1817 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1818
1819 if (FTH_STRING_LENGTH(fs) == 0)
1820 return (fth_make_array_var(1, fs));
1821
1822 result = fth_make_empty_array();
1823
1824 if (FTH_REGEXP_P(reg)) {
1825 FTH s;
1826 char *b;
1827 ficlInteger start, range, pos;
1828
1829 start = 0;
1830 range = FTH_STRING_LENGTH(fs);
1831 b = FTH_STRING_DATA(fs);
1832
1833 while ((pos = fth_regexp_search(reg, fs, start, range)) >= 0) {
1834 s = fth_make_string_len(b + start, pos - start);
1835 fth_array_push(result, s);
1836
1837 if (fth_array_length(fth_object_to_array(reg)) > 0) {
1838 s = fth_object_value_ref(reg, 0L);
1839 start = pos + fth_string_length(s);
1840 } else
1841 start = pos + 1;
1842 }
1843
1844 if ((range - start) >= 0) {
1845 s = fth_make_string_len(b + start, range - start);
1846 fth_array_push(result, s);
1847 }
1848 return (result);
1849 }
1850 s = str = FTH_STRDUP(FTH_STRING_DATA(fs));
1851 delim = FTH_STRING_P(reg) ? FTH_STRING_DATA(reg) : " ";
1852
1853 while ((p = strsep(&s, delim)) != NULL)
1854 if (*p != '\0')
1855 fth_array_push(result, fth_make_string(p));
1856
1857 FTH_FREE(str);
1858 return (result);
1859 }
1860
1861 /*-
1862 * Not a public function.
1863 *
1864 * The split string or regexp won't be removed (for io.c, fth_readlines()).
1865 *
1866 * FTH fs = fth_make_string("foo\nbar\nbaz");
1867 * fth_make_string_2(fs, fth_make_string("\n")); => #( "foo\n" "bar\n" "baz" )
1868 */
1869 FTH
fth_string_split_2(FTH fs,FTH reg)1870 fth_string_split_2(FTH fs, FTH reg)
1871 {
1872 char *b;
1873 ficlInteger start, range, pos, len;
1874 FTH result , s;
1875
1876 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1877 FTH_ASSERT_ARGS(FTH_STRREG_P(reg), reg, FTH_ARG2, "a string or regexp");
1878
1879 if (FTH_STRING_LENGTH(fs) == 0)
1880 return (fth_make_array_var(1, fs));
1881
1882 if (FTH_STRING_P(reg))
1883 reg = fth_make_regexp(FTH_STRING_DATA(reg));
1884
1885 start = 0;
1886 range = FTH_STRING_LENGTH(fs);
1887 b = FTH_STRING_DATA(fs);
1888 result = fth_make_empty_array();
1889
1890 while ((pos = fth_regexp_search(reg, fs, start, range)) >= 0) {
1891 s = fth_object_value_ref(reg, 0L);
1892 len = fth_string_length(s);
1893
1894 if ((pos + len - start) > 0) {
1895 s = fth_make_string_len(b + start, pos + len - start);
1896 fth_array_push(result, s);
1897 }
1898 start = pos + 1;
1899 }
1900
1901 if ((range - start) > 0) {
1902 s = fth_make_string_len(b + start, range - start);
1903 fth_array_push(result, s);
1904 }
1905 return (result);
1906 }
1907
1908 /*-
1909 * FTH fs = fth_make_string("hello world");
1910 * fth_string_substring(fs, 2, 4); => "ll"
1911 * fth_string_substring(fs, -4, -2); => "or"
1912 * fth_string_substring(fs, -4, fth_string_length(fs)); => "orld"
1913 */
1914 FTH
fth_string_substring(FTH fs,ficlInteger start,ficlInteger end)1915 fth_string_substring(FTH fs, ficlInteger start, ficlInteger end)
1916 {
1917 FTH res;
1918 size_t st;
1919
1920 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1921
1922 if (start < 0)
1923 start += FTH_STRING_LENGTH(fs);
1924
1925 if (start < 0 || start >= FTH_STRING_LENGTH(fs))
1926 FTH_OUT_OF_BOUNDS(FTH_ARG2, start);
1927
1928 if (end < 0)
1929 end += FTH_STRING_LENGTH(fs);
1930
1931 if (end < start || end > FTH_STRING_LENGTH(fs))
1932 end = FTH_STRING_LENGTH(fs);
1933
1934 res = fth_make_string_len(FTH_STRING_DATA(fs), end - start);
1935 st = (size_t) FTH_STRING_LENGTH(res);
1936 memmove(FTH_STRING_DATA(res), FTH_STRING_DATA(fs) + start, st);
1937 return (res);
1938 }
1939
1940 static void
ficl_string_substring(ficlVm * vm)1941 ficl_string_substring(ficlVm *vm)
1942 {
1943 #define h_string_substring "( str1 start end -- str2 ) return substring\n\
1944 \"hello world\" 2 4 string-substring => \"ll\"\n\
1945 \"hello world\" -4 -2 string-substring => \"or\"\n\
1946 \"hello world\" -4 nil string-substring => \"orld\"\n\
1947 Return new string from position START to, but excluding, position END. \
1948 If END is not an integer, END will be set to length of STR1; \
1949 negative index counts from backward. \
1950 Raise an OUT-OF-RANGE exception if index is not in range of string."
1951 FTH fs, last;
1952 ficlInteger beg, end;
1953
1954 FTH_STACK_CHECK(vm, 3, 1);
1955 last = fth_pop_ficl_cell(vm);
1956 beg = ficlStackPopInteger(vm->dataStack);
1957 fs = ficlStackPopFTH(vm->dataStack);
1958 end = (FTH_INTEGER_P(last)) ? FTH_INT_REF(last) : fth_string_length(fs);
1959 ficlStackPushFTH(vm->dataStack, fth_string_substring(fs, beg, end));
1960 }
1961
1962 /*-
1963 * Return the string, not a copy, changed to all chars upcase.
1964 *
1965 * FTH fs = fth_make_string("Foo");
1966 * fth_string_upcase(fs); => "FOO"
1967 * fth_printf("%S", fs); => "FOO"
1968 */
1969 FTH
fth_string_upcase(FTH fs)1970 fth_string_upcase(FTH fs)
1971 {
1972 ficlInteger i;
1973 char *b;
1974
1975 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1976
1977 if (FTH_STRING_LENGTH(fs) == 0)
1978 return (fs);
1979
1980 b = FTH_STRING_DATA(fs);
1981
1982 for (i = 0; i < FTH_STRING_LENGTH(fs); i++)
1983 b[i] = (char) toupper((int) b[i]);
1984
1985 FTH_INSTANCE_CHANGED(fs);
1986 return (fs);
1987 }
1988
1989 static void
ficl_string_upcase(ficlVm * vm)1990 ficl_string_upcase(ficlVm *vm)
1991 {
1992 #define h_string_upcase "( str1 -- str2 ) convert chars\n\
1993 \"Foo\" value s1\n\
1994 s1 string-upcase value s2\n\
1995 s1 => \"Foo\"\n\
1996 s2 => \"FOO\"\n\
1997 Return new string with all characters uppercase.\n\
1998 See also string-upcase!, string-downcase, string-capitalize."
1999 FTH fs;
2000
2001 FTH_STACK_CHECK(vm, 1, 1);
2002 fs = fth_string_copy(fth_pop_ficl_cell(vm));
2003 ficlStackPushFTH(vm->dataStack, fth_string_upcase(fs));
2004 }
2005
2006 static void
ficl_string_upcase_bang(ficlVm * vm)2007 ficl_string_upcase_bang(ficlVm *vm)
2008 {
2009 #define h_str_up_bang "( str -- str' ) convert chars\n\
2010 \"Foo\" value s1\n\
2011 s1 string-upcase! drop\n\
2012 s1 => \"FOO\"\n\
2013 Return STR changed to all characters uppercase.\n\
2014 See also string-upcase, string-downcase, string-capitalize."
2015 FTH fs;
2016
2017 FTH_STACK_CHECK(vm, 1, 1);
2018 fs = fth_pop_ficl_cell(vm);
2019 ficlStackPushFTH(vm->dataStack, fth_string_upcase(fs));
2020 }
2021
2022 /*-
2023 * Return the string, not a copy, changed to all chars downcase.
2024 *
2025 * FTH fs = fth_make_string("Foo");
2026 * fth_string_downcase(fs); => "foo"
2027 * fth_printf("%S", fs); => "foo"
2028 */
2029 FTH
fth_string_downcase(FTH fs)2030 fth_string_downcase(FTH fs)
2031 {
2032 ficlInteger i;
2033 char *b;
2034
2035 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
2036
2037 if (FTH_STRING_LENGTH(fs) == 0)
2038 return (fs);
2039
2040 b = FTH_STRING_DATA(fs);
2041
2042 for (i = 0; i < FTH_STRING_LENGTH(fs); i++)
2043 b[i] = (char) tolower((int) b[i]);
2044
2045 FTH_INSTANCE_CHANGED(fs);
2046 return (fs);
2047 }
2048
2049 static void
ficl_string_downcase(ficlVm * vm)2050 ficl_string_downcase(ficlVm *vm)
2051 {
2052 #define h_string_downcase "( str1 -- str2 ) convert chars\n\
2053 \"Foo\" value s1\n\
2054 s1 string-downcase value s2\n\
2055 s1 => \"Foo\"\n\
2056 s2 => \"foo\"\n\
2057 Return new string with all characters lowercase.\n\
2058 See also string-downcase!, string-upcase, string-capitalize."
2059 FTH fs;
2060
2061 FTH_STACK_CHECK(vm, 1, 1);
2062 fs = fth_string_copy(fth_pop_ficl_cell(vm));
2063 ficlStackPushFTH(vm->dataStack, fth_string_downcase(fs));
2064 }
2065
2066 static void
ficl_string_downcase_bang(ficlVm * vm)2067 ficl_string_downcase_bang(ficlVm *vm)
2068 {
2069 #define h_str_dn_bang "( str -- str' ) convert chars\n\
2070 \"Foo\" value s1\n\
2071 s1 string-downcase! drop\n\
2072 s1 => \"foo\"\n\
2073 Return STR changed to all characters lowercase.\n\
2074 See also string-downcase, string-upcase, string-capitalize."
2075 FTH fs;
2076
2077 FTH_STACK_CHECK(vm, 1, 1);
2078 fs = fth_pop_ficl_cell(vm);
2079 ficlStackPushFTH(vm->dataStack, fth_string_downcase(fs));
2080 }
2081
2082 /*-
2083 * Return the string, not a copy, changed to first char upcase and
2084 * the rest downcase.
2085 *
2086 * FTH fs = fth_make_string("foO");
2087 * fth_string_capitalize(fs); => "Foo"
2088 * fth_printf("%S", fs); => "Foo"
2089 */
2090 FTH
fth_string_capitalize(FTH fs)2091 fth_string_capitalize(FTH fs)
2092 {
2093 ficlInteger i;
2094 char *b;
2095
2096 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
2097
2098 if (FTH_STRING_LENGTH(fs) == 0)
2099 return (fs);
2100
2101 b = FTH_STRING_DATA(fs);
2102 b[0] = (char) toupper((int) b[0]);
2103
2104 for (i = 1; i < FTH_STRING_LENGTH(fs); i++)
2105 b[i] = (char) tolower((int) b[i]);
2106
2107 FTH_INSTANCE_CHANGED(fs);
2108 return (fs);
2109 }
2110
2111 static void
ficl_string_capitalize(ficlVm * vm)2112 ficl_string_capitalize(ficlVm *vm)
2113 {
2114 #define h_str_cap "( str1 -- str2 ) capitalize first char\n\
2115 \"foO\" value s1\n\
2116 s1 string-capitalize value s2\n\
2117 s1 => \"foO\"\n\
2118 s2 => \"Foo\"\n\
2119 Return new string with first character capitalized and \
2120 remaining characters in lowercase.\n\
2121 See also string-capitalize!, string-upcase, string-downcase."
2122 FTH fs;
2123
2124 FTH_STACK_CHECK(vm, 1, 1);
2125 fs = fth_string_copy(fth_pop_ficl_cell(vm));
2126 ficlStackPushFTH(vm->dataStack, fth_string_capitalize(fs));
2127 }
2128
2129 static void
ficl_string_capitalize_bang(ficlVm * vm)2130 ficl_string_capitalize_bang(ficlVm *vm)
2131 {
2132 #define h_str_c_b "( str -- str' ) capitalize first char\n\
2133 \"foO\" value s1\n\
2134 s1 string-capitalize! drop\n\
2135 s1 => \"Foo\"\n\
2136 Return STR changed to first character capitalized and \
2137 remaining characters to lowercase.\n\
2138 See also string-capitalize, string-upcase, string-downcase."
2139 FTH fs;
2140
2141 FTH_STACK_CHECK(vm, 1, 1);
2142 fs = fth_pop_ficl_cell(vm);
2143 ficlStackPushFTH(vm->dataStack, fth_string_capitalize(fs));
2144 }
2145
2146 /*-
2147 * Return the string, not a copy, replaced FROM with TO.
2148 *
2149 * FTH fs = fth_make_string("foo");
2150 * FTH from = fth_make_string("o");
2151 * FTH to = fth_make_string("a");
2152 * fth_string_replace(fs, from, to); => "faa"
2153 * fth_printf("%S", fs); => "faa"
2154 *
2155 * FTH fs = fth_make_string("foo");
2156 * FTH from = fth_make_string("oo");
2157 * FTH to = fth_make_string("a");
2158 * fth_string_replace(fs, from, to); => "fa"
2159 * fth_printf("%S", fs); => "fa"
2160 *
2161 * FTH fs = fth_make_string("foo");
2162 * FTH from = fth_make_string("o");
2163 * FTH to = fth_make_string("");
2164 * fth_string_replace(fs, from, to); => "f"
2165 * fth_printf("%S", fs); => "f"
2166 */
2167 FTH
fth_string_replace(FTH fs,FTH from,FTH to)2168 fth_string_replace(FTH fs, FTH from, FTH to)
2169 {
2170 char *tmp, *b, *cf, *ct;
2171 ficlInteger i, l, lf, lt;
2172 size_t st;
2173
2174 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
2175
2176 if (FTH_STRING_LENGTH(fs) == 0)
2177 return (fs);
2178
2179 FTH_ASSERT_ARGS(FTH_STRING_P(from), from, FTH_ARG2, "a string");
2180 FTH_ASSERT_ARGS(FTH_STRING_P(to), to, FTH_ARG3, "a string");
2181
2182 if (FTH_STRING_LENGTH(from) == 1 && FTH_STRING_LENGTH(to) == 1) {
2183 char f, t;
2184
2185 b = FTH_STRING_DATA(fs);
2186 f = FTH_STRING_DATA(from)[0];
2187 t = FTH_STRING_DATA(to)[0];
2188
2189 for (i = 0; i < FTH_STRING_LENGTH(fs); i++)
2190 if (b[i] == f)
2191 b[i] = t;
2192
2193 FTH_INSTANCE_CHANGED(fs);
2194 return (fs);
2195 }
2196 tmp = b = FTH_STRING_DATA(fs);
2197 cf = FTH_STRING_DATA(from);
2198 lf = FTH_STRING_LENGTH(from);
2199 ct = FTH_STRING_DATA(to);
2200 lt = FTH_STRING_LENGTH(to);
2201
2202 if (lt == 0) {
2203 while ((tmp = strstr(tmp, cf))) {
2204 i = tmp - b;
2205 /* delete */
2206 FTH_STRING_LENGTH(fs) -= lf;
2207 st = (size_t) (FTH_STRING_LENGTH(fs) - i);
2208 memmove(tmp, tmp + lf, st);
2209 b[FTH_STRING_LENGTH(fs)] = '\0';
2210 }
2211
2212 FTH_INSTANCE_CHANGED(fs);
2213 return (fs);
2214 }
2215 while ((tmp = strstr(tmp, cf))) {
2216 i = tmp - b;
2217
2218 /* delete */
2219 FTH_STRING_LENGTH(fs) -= lf;
2220 st = (size_t) (FTH_STRING_LENGTH(fs) - i);
2221 memmove(tmp, tmp + lf, st);
2222
2223 /* insert */
2224 st = FTH_STRING_TOP(fs) + FTH_STRING_LENGTH(fs) + lt + 1;
2225 l = NEW_SEQ_LENGTH(st);
2226
2227 if (l > MAX_SEQ_LENGTH)
2228 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, l, "too long");
2229
2230 if (l > FTH_STRING_BUF_LENGTH(fs)) {
2231 FTH_STRING_BUF_LENGTH(fs) = l;
2232 st = (size_t) l;
2233 FTH_STRING_BUF(fs) =
2234 FTH_REALLOC(FTH_STRING_BUF(fs), st);
2235 FTH_STRING_DATA(fs) =
2236 FTH_STRING_BUF(fs) + FTH_STRING_TOP(fs);
2237 }
2238 st = (size_t) (FTH_STRING_LENGTH(fs) - i);
2239 memmove(FTH_STRING_DATA(fs) + i + lt, b + i, st);
2240 st = (size_t) lt;
2241 memmove(b + i, ct, st);
2242 FTH_STRING_LENGTH(fs) += lt;
2243 b[FTH_STRING_LENGTH(fs)] = '\0';
2244 /* skip over added "to" string */
2245 tmp += lt;
2246 }
2247
2248 FTH_INSTANCE_CHANGED(fs);
2249 return (fs);
2250 }
2251
2252 static void
ficl_string_replace(ficlVm * vm)2253 ficl_string_replace(ficlVm *vm)
2254 {
2255 #define h_string_replace "( str1 from to -- str2 ) replace in string\n\
2256 \"foo\" value s1\n\
2257 s1 \"o\" \"a\" string-replace value s2\n\
2258 s1 \"oo\" \"a\" string-replace value s3\n\
2259 s1 \"o\" \"\" string-replace value s4\n\
2260 s1 => \"foo\"\n\
2261 s2 => \"faa\"\n\
2262 s3 => \"fa\"\n\
2263 s4 => \"f\"\n\
2264 Return new string object with string FROM replaced by string TO. \
2265 If TO is the empty string, delete the FROM part from STR1.\n\
2266 See also string-replace!."
2267 FTH str, from, to;
2268
2269 FTH_STACK_CHECK(vm, 3, 1);
2270 to = fth_pop_ficl_cell(vm);
2271 from = fth_pop_ficl_cell(vm);
2272 str = fth_string_copy(fth_pop_ficl_cell(vm));
2273 ficlStackPushFTH(vm->dataStack, fth_string_replace(str, from, to));
2274 }
2275
2276 static void
ficl_string_replace_bang(ficlVm * vm)2277 ficl_string_replace_bang(ficlVm *vm)
2278 {
2279 #define h_str_rep_bang "( str from to -- str' ) replace in string\n\
2280 \"foo\" value s1\n\
2281 \"foo\" value s2\n\
2282 \"foo\" value s3\n\
2283 s1 \"o\" \"a\" string-replace! drop\n\
2284 s2 \"oo\" \"a\" string-replace! drop\n\
2285 s3 \"o\" \"\" string-replace! drop\n\
2286 s1 => \"faa\"\n\
2287 s2 => \"fa\"\n\
2288 s3 => \"f\"\n\
2289 Return changed STR with string FROM replaced by string TO. \
2290 If TO is the empty string, delete the FROM part from STR.\n\
2291 See also string-replace."
2292 FTH str, from, to;
2293
2294 FTH_STACK_CHECK(vm, 3, 1);
2295 to = fth_pop_ficl_cell(vm);
2296 from = fth_pop_ficl_cell(vm);
2297 str = fth_pop_ficl_cell(vm);
2298 ficlStackPushFTH(vm->dataStack, fth_string_replace(str, from, to));
2299 }
2300
2301 /*-
2302 * Return the string, not a copy, with possible trailing \n removed.
2303 *
2304 * FTH fs = fth_make_string("foo\n");
2305 * fth_string_chomp(fs); => "foo"
2306 * FTH fs = fth_make_string("bar");
2307 * fth_string_chomp(fs); => "bar"
2308 */
2309 FTH
fth_string_chomp(FTH fs)2310 fth_string_chomp(FTH fs)
2311 {
2312 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
2313
2314 if (FTH_STRING_DATA(fs)[FTH_STRING_LENGTH(fs) - 1] == '\n')
2315 fth_string_pop(fs);
2316
2317 return (fs);
2318 }
2319
2320 static void
ficl_string_chomp(ficlVm * vm)2321 ficl_string_chomp(ficlVm *vm)
2322 {
2323 #define h_string_chomp "( str1 -- str2 ) remove CR\n\
2324 \"foo\\n\" value s1\n\
2325 \"bar\" value s2\n\
2326 s1 string-chomp => \"foo\"\n\
2327 s2 string-chomp => \"bar\"\n\
2328 Return new string object with possible trailing CR removed.\n\
2329 See also string-chomp!."
2330 FTH fs;
2331
2332 FTH_STACK_CHECK(vm, 1, 1);
2333 fs = fth_string_copy(fth_pop_ficl_cell(vm));
2334 ficlStackPushFTH(vm->dataStack, fth_string_chomp(fs));
2335 }
2336
2337 static void
ficl_string_chomp_bang(ficlVm * vm)2338 ficl_string_chomp_bang(ficlVm *vm)
2339 {
2340 #define h_string_chomp_bang "( str -- str' ) remove CR\n\
2341 \"foo\\n\" value s1\n\
2342 \"bar\" value s2\n\
2343 s1 string-chomp drop\n\
2344 s2 string-chomp drop\n\
2345 s1 => \"foo\"\n\
2346 s2 => \"bar\"\n\
2347 Return changed STR with possible trailing CR removed.\n\
2348 See also string-chomp."
2349 FTH fs;
2350
2351 FTH_STACK_CHECK(vm, 1, 1);
2352 fs = fth_pop_ficl_cell(vm);
2353 ficlStackPushFTH(vm->dataStack, fth_string_chomp(fs));
2354 }
2355
2356 /*-
2357 * Return a formatted string created from the extended printf(3)
2358 * format string FMT and possible arguments in ARGS. ARGS can be
2359 * an array, any single object, FTH_FALSE or FTH_NIL. If ARGS is
2360 * an array, it should have as many elements as required by the
2361 * format string, if ARGS is a single object, the format string
2362 * should only have one format sign, if ARGS is FTH_FALSE or FTH_NIL,
2363 * ARGS is ignored and the format string itself is returned. If
2364 * FMT is the empty string, an empty string is returned, no matter
2365 * what's in ARGS.
2366 *
2367 * FTH fmt = fth_make_string("%04d %8.2f %b %X %o");
2368 * FTH args = fth_make_array_var(5,
2369 * INT_TO_FIX(128),
2370 * fth_make_float(M_PI),
2371 * INT_TO_FIX(255),
2372 * INT_TO_FIX(255),
2373 * INT_TO_FIX(255));
2374 * fth_string_format(fmt, args); => "0128 3.14 11111111 FF 377"
2375 *
2376 * FTH fmt = fth_make_string("we print %S");
2377 * FTH arg = INT_TO_FIX(10);
2378 * fth_string_format(fmt, arg); => "we print 10"
2379 *
2380 * FTH fmt = fth_make_string("simple string");
2381 * fth_string_format(fmt, FTH_FALSE); => "simple string"
2382 * fth_string_format(fmt, FTH_NIL); => "simple string"
2383 *
2384 * FTH fmt = fth_make_empty_string();
2385 * fth_string_format(fmt, args); => ""
2386 */
2387 FTH
fth_string_format(FTH fs,FTH args)2388 fth_string_format(FTH fs, FTH args)
2389 {
2390 #define h_string_format "( fmt args -- str ) return formatted string\n\
2391 \"%04d %8.2f %b %X %o\" #( 128 pi 255 255 255 ) string-format\n\
2392 => \"0128 3.14 11111111 FF 377\"\n\
2393 FMT is a printf(3) format string and ARGS the needed arguments \
2394 which may be an array, a single argument or #f.\n\
2395 %n.mX n: entire format length\n\
2396 m: precision (float)\n\
2397 X: one of the following flags\n\
2398 aAeEfFgG float\n\
2399 bB binary\n\
2400 c char\n\
2401 d decimal\n\
2402 oO octal\n\
2403 p object-inspect (like Ruby's %p)\n\
2404 s object->string (char *)\n\
2405 S object-dump (like Emacs' %S)\n\
2406 u unsigned\n\
2407 xX hex\n\
2408 See also fth-format."
2409 char *fmt;
2410
2411 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
2412
2413 if (FTH_FALSE_P(args) || FTH_NIL_P(args))
2414 return (fs);
2415 else if (!FTH_ARRAY_P(args))
2416 args = fth_make_array_var(1, args);
2417
2418 fmt = FTH_STRING_REF(fs);
2419
2420 if (fmt == NULL)
2421 return (fth_make_empty_string());
2422
2423 return (fth_string_vformat(fmt, args));
2424 }
2425
2426 /*-
2427 * Evaluates the string.
2428 *
2429 * ficlVm *vm = FTH_FICL_VM();
2430 * FTH fs = fth_make_string("3 4 +");
2431 * fth_string_eval(fs); => puts 7 on stack
2432 * ficlStackPopInteger(vm->dataStack); => 7
2433 *
2434 * ficlStackPushInteger(vm->dataStack, 7); => puts 7 on stack
2435 * FTH fs = fth_make_string("3 4 + +");
2436 * fth_string_eval(fs); => puts 14 on stack
2437 * ficlStackPopInteger(vm->dataStack); => 14
2438 *
2439 * ficlStackPushInteger(vm->dataStack, 7); => puts 7 on stack
2440 * FTH fs = fth_make_string("3 4 + + . cr");
2441 * fth_string_eval(fs); => prints 14
2442 */
2443 int
fth_string_eval(FTH fs)2444 fth_string_eval(FTH fs)
2445 {
2446 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
2447 return (fth_evaluate(FTH_FICL_VM(), FTH_STRING_REF(fs)));
2448 }
2449
2450 static void
ficl_string_eval(ficlVm * vm)2451 ficl_string_eval(ficlVm *vm)
2452 {
2453 #define h_string_eval "( string -- ?? ) evaluate string\n\
2454 \"3 4 +\" string-eval => 7\n\
2455 7 \"3 4 + +\" string-eval => 14\n\
2456 7 \"3 4 + + .\" string-eval \\ prints 14\n\
2457 Evaluate STRING; values already on stack can be accessed, \
2458 resulting values remain on stack.\n\
2459 See also string-eval-with-status."
2460 FTH_STACK_CHECK(vm, 1, 0);
2461
2462 if (fth_evaluate(vm, pop_cstring(vm)) == FICL_VM_STATUS_USER_EXIT)
2463 fth_exit(EXIT_SUCCESS);
2464 }
2465
2466 static void
ficl_string_eval_with_status(ficlVm * vm)2467 ficl_string_eval_with_status(ficlVm *vm)
2468 {
2469 #define h_es "( string -- ?? eval-status ) eval\n\
2470 \"3 4 +\" string-eval-with-status drop => 7\n\
2471 7 \"3 4 + +\" string-eval-with-status drop => 14\n\
2472 7 \"3 4 + + .\" string-eval-with-status drop \\ prints 14\n\
2473 Evaluate STRING and return EVAL-STATUS on top of stack; \
2474 values already on stack can be accessed, resulting values remain on stack. \
2475 EVAL-STATUS can be one of the following constants:\n\
2476 BREAK Ficl Break\n\
2477 ERROR_EXIT Ficl Error Exit\n\
2478 INNER_EXIT Ficl Inner Exit\n\
2479 OUT_OF_TEXT Ficl Out of Text\n\
2480 RESTART Ficl Restart\n\
2481 USER_EXIT Ficl User Exit\n\
2482 See also string-eval."
2483 ficlInteger i;
2484
2485 FTH_STACK_CHECK(vm, 1, 1);
2486 i = (ficlInteger) fth_evaluate(vm, pop_cstring(vm));
2487 ficlStackPushInteger(vm->dataStack, i);
2488 }
2489
2490 static void
ficl_string_to_forth_string(ficlVm * vm)2491 ficl_string_to_forth_string(ficlVm *vm)
2492 {
2493 #define h_string_to_fstring "( str -- addr len ) return Forth string\n\
2494 \"10 20 + .\" string>$ evaluate => 30\n\
2495 \"hello\" string>$ type => hello\n\
2496 Return string object STR converted to a Forth string with ADDR LEN. \
2497 Standard words like TYPE and EVALUATE require this kind of string.\n\
2498 See also $>string."
2499 FTH_STACK_CHECK(vm, 1, 2);
2500 push_forth_string(vm, pop_cstring(vm));
2501 }
2502
2503 static void
ficl_forth_string_to_string(ficlVm * vm)2504 ficl_forth_string_to_string(ficlVm *vm)
2505 {
2506 #define h_fstring_to_string "( addr len -- str ) return string\n\
2507 s\" 10 20 + .\" $>string string-eval => 30\n\
2508 s\" hello\" $>string .string => hello\n\
2509 Return Forth string ADDR LEN as string object. \
2510 Standard words like TYPE and EVALUATE require this kind of string.\n\
2511 See also string>$."
2512 char *str;
2513 size_t len;
2514
2515 FTH_STACK_CHECK(vm, 2, 1);
2516 len = (size_t) ficlStackPopUnsigned(vm->dataStack);
2517 str = ficlStackPopPointer(vm->dataStack);
2518 ficlStackPushFTH(vm->dataStack, fth_make_string_len(str, len));
2519 }
2520
2521 static ficlWord *string_immutable_paren;
2522 /*
2523 * Push a fresh copy of the saved string back on stack. So the
2524 * original content of the string won't be changed or destroyed.
2525 */
2526 static void
ficl_string_immutable_paren(ficlVm * vm)2527 ficl_string_immutable_paren(ficlVm *vm)
2528 {
2529 push_cstring(vm, pop_cstring(vm));
2530 }
2531
2532 static void
ficl_make_string_im(ficlVm * vm)2533 ficl_make_string_im(ficlVm *vm)
2534 {
2535 #define h_make_string_im "( space<ccc>\" -- str ) string (parse word)\n\
2536 $\" foo\" => \"foo\"\n\
2537 Parse string CCC delimited by '\"' at compile time and \
2538 at interpret time return parsed string."
2539 char *buf;
2540 FTH fs;
2541
2542 buf = parse_input_buffer(vm, "\""); /* must be freed */
2543 fs = fth_make_string(buf);
2544 FTH_FREE(buf);
2545
2546 if (vm->state == FICL_VM_STATE_COMPILE) {
2547 ficlDictionary *dict;
2548 ficlUnsigned u;
2549
2550 dict = ficlVmGetDictionary(vm);
2551 u = (ficlUnsigned) ficlInstructionLiteralParen;
2552 ficlDictionaryAppendUnsigned(dict, u);
2553 ficlDictionaryAppendFTH(dict, fs);
2554 ficlDictionaryAppendPointer(dict, string_immutable_paren);
2555 return;
2556 }
2557 ficlStackPushFTH(vm->dataStack, fs);
2558 }
2559
2560 void
init_string_type(void)2561 init_string_type(void)
2562 {
2563 string_tag = make_object_type(FTH_STR_STRING, FTH_STRING_T);
2564 fth_set_object_inspect(string_tag, str_inspect);
2565 fth_set_object_to_string(string_tag, str_to_string);
2566 fth_set_object_dump(string_tag, str_dump);
2567 fth_set_object_to_array(string_tag, str_to_array);
2568 fth_set_object_copy(string_tag, str_to_string);
2569 fth_set_object_value_ref(string_tag, str_ref);
2570 fth_set_object_value_set(string_tag, str_set);
2571 fth_set_object_equal_p(string_tag, str_equal_p);
2572 fth_set_object_length(string_tag, str_length);
2573 fth_set_object_free(string_tag, str_free);
2574 }
2575
2576 void
init_string(void)2577 init_string(void)
2578 {
2579 fth_set_object_apply(string_tag, (void *) str_ref, 1, 0, 0);
2580
2581 /* struct members */
2582 init_str_length();
2583 init_str_buf_length();
2584 init_str_top();
2585
2586 /* string */
2587 FTH_PRI1("string-length", ficl_string_length, h_string_length);
2588 FTH_PRI1("string?", ficl_string_p, h_string_p);
2589 FTH_PRI1("char?", ficl_char_p, h_char_p);
2590 FTH_PRI1("make-string", ficl_make_string, h_make_string);
2591 FTH_PRI1("string-concat", ficl_values_to_string, h_values_to_string);
2592 FTH_PRI1(">string", ficl_values_to_string, h_values_to_string);
2593 FTH_PRI1("\"\"", ficl_make_empty_string, h_empty_string);
2594 FTH_PRI1("$space", ficl_space_string, h_space_string);
2595 FTH_PRI1("$spaces", ficl_spaces_string, h_spaces_string);
2596 FTH_PRI1("$cr", ficl_cr_string, h_cr_string);
2597 FTH_PROC("fth-format", ficl_fth_format, 1, 1, 0, h_fth_format);
2598 FTH_VOID_PROC("fth-print", ficl_fth_print, 1, 1, 0, h_fth_print);
2599 FTH_VOID_PROC("fth-warning", ficl_fth_warning, 1, 1, 0, h_fth_warning);
2600 FTH_VOID_PROC("fth-error", ficl_fth_error, 1, 1, 0, h_fth_error);
2601 FTH_VOID_PROC("fth-die", ficl_fth_die, 1, 1, 0, h_fth_die);
2602 FTH_PRI1("warning", ficl_warning, h_warning);
2603 FTH_PRI1("warn", ficl_warning, h_warning);
2604 FTH_PRI1("error", ficl_error, h_error);
2605 FTH_PRI1("die", ficl_die, h_die);
2606 FTH_PRI1(".string", ficl_print_object, h_print_object);
2607 FTH_PRI1(".$", ficl_print_object, h_print_object);
2608 FTH_PRI1(".g", ficl_print_object, h_print_object);
2609 FTH_PRI1(".error", ficl_error_object, h_error_object);
2610 FTH_PRI1(".stdout", ficl_print_stdout, h_print_stdout);
2611 FTH_PRI1(".stderr", ficl_print_stderr, h_print_stderr);
2612 FTH_PRI1(".debug", ficl_print_debug, h_print_debug);
2613 FTH_PRI1("string-cmp", ficl_string_cmp, h_string_cmp);
2614 FTH_PRI1("string=", ficl_string_equal_p, h_string_equal_p);
2615 FTH_PRI1("string<>", ficl_string_not_equal_p, h_string_not_equal_p);
2616 FTH_PRI1("string<", ficl_string_less_p, h_string_less_p);
2617 FTH_PRI1("string>", ficl_string_greater_p, h_string_greater_p);
2618 FTH_PROC("string->array", fth_string_to_array, 1, 0, 0, h_str_to_ary);
2619 FTH_PROC("string-copy", fth_string_copy, 1, 0, 0, h_string_copy);
2620 FTH_PRI1("string-ref", ficl_string_ref, h_string_ref);
2621 FTH_PRI1("string-set!", ficl_string_set, h_string_set);
2622 FTH_PROC("string-push", fth_string_push, 2, 0, 0, h_string_push);
2623 FTH_PROC("<<", fth_string_push, 2, 0, 0, h_string_push);
2624 FTH_PROC("string-pop", fth_string_pop, 1, 0, 0, h_string_pop);
2625 FTH_PROC("string-unshift", fth_string_unshift, 2, 0, 0, h_str_unshift);
2626 FTH_PROC("string-shift", fth_string_shift, 1, 0, 0, h_string_shift);
2627 FTH_PROC("string-append", fth_string_append, 2, 0, 0, h_string_append);
2628 FTH_PROC("$+", fth_string_append, 2, 0, 0, h_string_append);
2629 FTH_PRI1("string-reverse", ficl_string_reverse, h_string_reverse);
2630 FTH_PRI1("string-reverse!", ficl_string_reverse_bang, h_str_rev_bang);
2631 FTH_PRI1("string-insert!", ficl_string_insert, h_string_insert);
2632 FTH_PRI1("string-delete!", ficl_string_delete, h_string_delete);
2633 FTH_PROC("string-fill", fth_string_fill, 2, 0, 0, h_string_fill);
2634 FTH_PROC("string-index", fth_string_index, 2, 0, 0, h_string_index);
2635 FTH_PRI1("string-member?", ficl_string_member_p, h_string_member_p);
2636 FTH_PROC("string-find", fth_string_find, 2, 0, 0, h_string_find);
2637 FTH_PROC("string-split", fth_string_split, 2, 0, 0, h_string_split);
2638 FTH_PRI1("string-substring", ficl_string_substring, h_string_substring);
2639 FTH_PRI1("string-upcase", ficl_string_upcase, h_string_upcase);
2640 FTH_PRI1("string-upcase!", ficl_string_upcase_bang, h_str_up_bang);
2641 FTH_PRI1("string-downcase", ficl_string_downcase, h_string_downcase);
2642 FTH_PRI1("string-downcase!", ficl_string_downcase_bang, h_str_dn_bang);
2643 FTH_PRI1("string-capitalize", ficl_string_capitalize, h_str_cap);
2644 FTH_PRI1("string-capitalize!", ficl_string_capitalize_bang, h_str_c_b);
2645 FTH_PRI1("string-replace", ficl_string_replace, h_string_replace);
2646 FTH_PRI1("string-replace!", ficl_string_replace_bang, h_str_rep_bang);
2647 FTH_PRI1("string-chomp", ficl_string_chomp, h_string_chomp);
2648 FTH_PRI1("string-chomp!", ficl_string_chomp_bang, h_string_chomp_bang);
2649 FTH_PROC("string-format", fth_string_format, 2, 0, 0, h_string_format);
2650 FTH_PROC("format", fth_string_format, 2, 0, 0, h_string_format);
2651 FTH_PRI1("string-eval", ficl_string_eval, h_string_eval);
2652 FTH_PRI1("string-eval-with-status", ficl_string_eval_with_status, h_es);
2653 FTH_PRI1("string>$", ficl_string_to_forth_string, h_string_to_fstring);
2654 FTH_PRI1("$>string", ficl_forth_string_to_string, h_fstring_to_string);
2655 FTH_PRIM_IM("$\"", ficl_make_string_im, h_make_string_im);
2656 fth_define_constant("INNER_EXIT",
2657 (FTH) FICL_VM_STATUS_INNER_EXIT, NULL);
2658 fth_define_constant("OUT_OF_TEXT",
2659 (FTH) FICL_VM_STATUS_OUT_OF_TEXT, NULL);
2660 fth_define_constant("RESTART", (FTH) FICL_VM_STATUS_RESTART, NULL);
2661 fth_define_constant("USER_EXIT", (FTH) FICL_VM_STATUS_USER_EXIT, NULL);
2662 fth_define_constant("ERROR_EXIT",
2663 (FTH) FICL_VM_STATUS_ERROR_EXIT, NULL);
2664 fth_define_constant("BREAK", (FTH) FICL_VM_STATUS_BREAK, NULL);
2665 string_immutable_paren = ficlDictionaryAppendPrimitive(FTH_FICL_DICT(),
2666 "(string-immutable)", ficl_string_immutable_paren,
2667 FICL_WORD_COMPILE_ONLY);
2668 FTH_ADD_FEATURE_AND_INFO(FTH_STR_STRING, h_list_of_string_functions);
2669 }
2670
2671 /*
2672 * string.c ends here
2673 */
2674