2
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4
This file is part of GNU Common Lisp, herein referred to as GCL
6
GCL is free software; you can redistribute it and/or modify it under
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
8
the Free Software Foundation; either version 2, or (at your option)
11
GCL is distributed in the hope that it will be useful, but WITHOUT
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
14
License for more details.
16
You should have received a copy of the GNU Library General Public License
17
along with GCL; see the file COPYING. If not, write to the Free Software
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
33
object sKinitial_element;
36
alloc_simple_string(l)
41
x = alloc_object(t_string);
42
x->st.st_hasfillp = FALSE;
43
x->st.st_adjustable = FALSE;
44
x->st.st_displaced = Cnil;
45
x->st.st_dim = x->st.st_fillp = l;
51
Make_simple_string(s) makes a simple string from C string s.
62
for (l = 0; s[l] != '\0'; l++)
64
x = alloc_simple_string(l);
66
p = alloc_relblock(l);
67
for (i = 0; i < l; i++)
76
This correponds to string= (just the string equality).
85
if (type_of(x) != t_string || type_of(y) != t_string)
86
error("string expected");
92
for (i = 0; i < j; i++)
93
if (x->st.st_self[i] != y->st.st_self[i])
99
This corresponds to string-equal
100
(string equality ignoring the case).
110
if (type_of(x) != t_string || type_of(y) != t_string)
111
error("string expected");
119
for (i = 0; i < j; i++)
120
if ((isLower(p[i]) ? p[i] - ('a' - 'A') : p[i])
121
!= (isLower(q[i]) ? q[i] - ('a' - 'A') : q[i]))
127
Copy_simple_string(x) copies string x to a simple string.
130
copy_simple_string(x)
139
if (type_of(x) != t_string)
140
error("string expected");
143
y = alloc_object(t_string);
144
y->st.st_dim = y->st.st_fillp = x->st.st_fillp;
145
y->st.st_hasfillp = FALSE;
146
y->st.st_adjustable = FALSE;
147
y->st.st_displaced = Cnil;
148
y->st.st_self = NULL;
150
y->st.st_self = alloc_relblock(x->st.st_fillp);
151
for (i = 0; i < x->st.st_fillp; i++)
152
y->st.st_self[i] = x->st.st_self[i];
166
switch (type_of(x)) {
169
y = alloc_simple_string(x->s.s_fillp);
171
if (x->s.s_self < heap_end)
172
y->st.st_self = x->s.s_self;
174
y->st.st_self = alloc_relblock(x->s.s_fillp);
175
for (i = 0; i < x->s.s_fillp; i++)
176
y->st.st_self[i] = x->s.s_self[i];
183
x = coerce_to_character(x);
188
y = alloc_simple_string(1);
190
y->st.st_self = alloc_relblock(1);
191
y->st.st_self[0] = char_code(x);
199
FEerror("~S cannot be coerced to a string.", 1, x);
205
check_type_string(&s);
206
if (type_of(i) != t_fixnum)
208
if ((j = fix(i)) < 0 || j >= s->st.st_fillp)
210
@(return `code_char(s->ust.ust_self[j])`)
218
check_type_string(&vs_base[0]);
219
if (type_of(vs_base[1]) != t_fixnum)
220
illegal_index(vs_base[0], vs_base[1]);
221
if ((j = fix(vs_base[1])) < 0 || j >= vs_base[0]->st.st_fillp)
222
illegal_index(vs_base[0], vs_base[1]);
223
check_type_character(&vs_base[2]);
224
vs_base[0]->st.st_self[j] = char_code(vs_base[2]);
228
get_string_start_end(string, start, end, ps, pe)
229
object string, start, end;
234
else if (type_of(start) != t_fixnum)
242
*pe = string->st.st_fillp;
245
} else if (type_of(end) != t_fixnum)
249
if (*pe < *ps || *pe > string->st.st_fillp)
255
FEerror("~S and ~S are illegal as :START and :END~%\
256
for the string ~S.", 3, start, end, string);
259
@(defun string_eq (string1 string2
260
&key start1 end1 start2 end2)
263
string1 = coerce_to_string(string1);
264
string2 = coerce_to_string(string2);
265
get_string_start_end(string1, start1, end1, &s1, &e1);
266
get_string_start_end(string2, start2, end2, &s2, &e2);
267
if (e1 - s1 != e2 - s2)
270
if (string1->st.st_self[s1++] !=
271
string2->st.st_self[s2++])
276
@(defun string_equal (string1 string2
277
&key start1 end1 start2 end2)
281
string1 = coerce_to_string(string1);
282
string2 = coerce_to_string(string2);
283
get_string_start_end(string1, start1, end1, &s1, &e1);
284
get_string_start_end(string2, start2, end2, &s2, &e2);
285
if (e1 - s1 != e2 - s2)
288
i1 = string1->st.st_self[s1++];
289
i2 = string2->st.st_self[s2++];
301
int string_sign, string_boundary;
303
@(defun string_cmp (string1 string2
304
&key start1 end1 start2 end2)
309
string1 = coerce_to_string(string1);
310
string2 = coerce_to_string(string2);
311
get_string_start_end(string1, start1, end1, &s1, &e1);
312
get_string_start_end(string2, start2, end2, &s2, &e2);
315
@(return `string_sign>0 ? Cnil : make_fixnum(s1)`)
316
i1 = string1->ust.ust_self[s1];
317
i2 = string2->ust.ust_self[s2];
318
if (string_sign == 0) {
320
@(return `make_fixnum(s1)`)
322
s = string_sign*(i2-i1);
324
@(return `make_fixnum(s1)`)
332
@(return `string_boundary==0 ? make_fixnum(s1) : Cnil`)
333
@(return `string_sign>=0 ? make_fixnum(s1) : Cnil`)
336
Lstring_l() { string_sign = 1; string_boundary = 1; Lstring_cmp(); }
337
Lstring_g() { string_sign = -1; string_boundary = 1; Lstring_cmp(); }
338
Lstring_le() { string_sign = 1; string_boundary = 0; Lstring_cmp(); }
339
Lstring_ge() { string_sign = -1; string_boundary = 0; Lstring_cmp(); }
340
Lstring_neq() { string_sign = 0; string_boundary = 1; Lstring_cmp(); }
342
@(defun string_compare (string1 string2
343
&key start1 end1 start2 end2)
348
string1 = coerce_to_string(string1);
349
string2 = coerce_to_string(string2);
350
get_string_start_end(string1, start1, end1, &s1, &e1);
351
get_string_start_end(string2, start2, end2, &s2, &e2);
354
@(return `string_sign>0 ? Cnil : make_fixnum(s1)`)
355
i1 = string1->ust.ust_self[s1];
358
i2 = string2->ust.ust_self[s2];
361
if (string_sign == 0) {
363
@(return `make_fixnum(s1)`)
365
s = string_sign*(i2-i1);
367
@(return `make_fixnum(s1)`)
375
@(return `string_boundary==0 ? make_fixnum(s1) : Cnil`)
376
@(return `string_sign>=0 ? make_fixnum(s1) : Cnil`)
379
Lstring_lessp() { string_sign = 1; string_boundary = 1; Lstring_compare(); }
380
Lstring_greaterp() { string_sign = -1; string_boundary = 1; Lstring_compare(); }
381
Lstring_not_greaterp(){ string_sign = 1; string_boundary = 0; Lstring_compare(); }
382
Lstring_not_lessp() { string_sign = -1; string_boundary = 0; Lstring_compare(); }
383
Lstring_not_equal() { string_sign = 0; string_boundary = 1; Lstring_compare(); }
386
@(defun make_string (size
387
&key (initial_element `code_char(' ')`)
391
while (type_of(size) != t_fixnum || fix(size) < 0)
393
= wrong_type_argument(TSnon_negative_integer, size);
394
/* bignum not allowed, this is PRACTICAL!! */
395
while (type_of(initial_element) != t_character ||
396
char_bits(initial_element) != 0 ||
397
char_font(initial_element) != 0)
399
= wrong_type_argument(sLstring_char, initial_element);
401
x = alloc_simple_string(fix(size));
402
x->st.st_self = alloc_relblock(fix(size));
403
for (i = 0; i < fix(size); i++)
404
x->st.st_self[i] = char_code(initial_element);
410
member_char(c, char_bag)
418
switch (type_of(char_bag)) {
421
while (!endp(char_bag)) {
422
if (type_of(char_bag->c.c_car) == t_character
423
&& c == char_code(char_bag->c.c_car))
425
char_bag = char_bag->c.c_cdr;
430
for (i = 0, f = char_bag->v.v_fillp; i < f; i++) {
431
if (type_of(char_bag->v.v_self[i]) != t_character
432
&& c == char_code(char_bag->v.v_self[i]))
438
for (i = 0, f = char_bag->st.st_fillp; i < f; i++) {
439
if (c == char_bag->st.st_self[i])
448
FEerror("~S is not a sequence.", 1, char_bag);
453
Lstring_trim() { left_trim = right_trim = TRUE; Lstring_trim0(); }
454
Lstring_left_trim() { left_trim = TRUE; right_trim = FALSE; Lstring_trim0(); }
455
Lstring_right_trim() { left_trim = FALSE; right_trim = TRUE; Lstring_trim0();}
457
@(defun string_trim0 (char_bag strng &aux res)
460
strng = coerce_to_string(strng);
462
j = strng->st.st_fillp - 1;
465
if (!member_char(strng->st.st_self[i], char_bag))
469
if (!member_char(strng->st.st_self[j], char_bag))
473
res = alloc_simple_string(k);
474
res->st.st_self = alloc_relblock(k);
475
for (j = 0; j < k; j++)
476
res->st.st_self[j] = strng->st.st_self[i + j];
481
static char_upcase(c, bp)
485
return(c - ('a' - 'A'));
490
static char_downcase(c, bp)
494
return(c + ('a' - 'A'));
499
static char_capitalize(c, bp)
506
} else if (isUpper(c)) {
510
} else if (!isDigit(c))
515
@(defun string_case (strng &key start end &aux conv)
519
strng = coerce_to_string(strng);
520
get_string_start_end(strng, start, end, &s, &e);
521
conv = copy_simple_string(strng);
523
for (i = s; i < e; i++)
524
conv->st.st_self[i] =
525
(*casefun)(conv->st.st_self[i], &b);
529
Lstring_upcase() { casefun = char_upcase; Lstring_case(); }
530
Lstring_downcase() { casefun = char_downcase; Lstring_case(); }
531
Lstring_capitalize() { casefun = char_capitalize; Lstring_case(); }
534
@(defun nstring_case (strng &key start end)
538
check_type_string(&strng);
539
get_string_start_end(strng, start, end, &s, &e);
541
for (i = s; i < e; i++)
542
strng->st.st_self[i] =
543
(*casefun)(strng->st.st_self[i], &b);
547
Lnstring_upcase() { casefun = char_upcase; Lnstring_case(); }
548
Lnstring_downcase() { casefun = char_downcase; Lnstring_case(); }
549
Lnstring_capitalize() { casefun = char_capitalize; Lnstring_case(); }
554
@(return `coerce_to_string(x)`)
557
siLstring_concatenate()
562
narg = vs_top - vs_base;
563
for (i = 0, l = 0; i < narg; i++) {
564
vs_base[i] = coerce_to_string(vs_base[i]);
565
l += vs_base[i]->st.st_fillp;
569
vs_push(alloc_simple_string(l));
570
(*v)->st.st_self = alloc_relblock(l);
571
for (i = 0, l = 0; i < narg; i++)
572
for (m = 0; m < vs_base[i]->st.st_fillp; m++)
573
(*v)->st.st_self[l++]
574
= vs_base[i]->st.st_self[m];
576
vs_top = vs_base + 1;
580
init_string_function()
582
sKstart1 = make_keyword("START1");
583
sKend1 = make_keyword("END1");
584
sKstart2 = make_keyword("START2");
585
sKend2 = make_keyword("END2");
586
sKinitial_element = make_keyword("INITIAL-ELEMENT");
587
sKstart = make_keyword("START");
588
sKend = make_keyword("END");
590
make_function("CHAR", Lchar);
591
make_si_function("CHAR-SET", siLchar_set);
592
make_function("SCHAR", Lchar);
593
make_si_function("SCHAR-SET", siLchar_set);
594
make_function("STRING=", Lstring_eq);
595
make_function("STRING-EQUAL", Lstring_equal);
596
make_function("STRING<", Lstring_l);
597
make_function("STRING>", Lstring_g);
598
make_function("STRING<=", Lstring_le);
599
make_function("STRING>=", Lstring_ge);
600
make_function("STRING/=", Lstring_neq);
601
make_function("STRING-LESSP", Lstring_lessp);
602
make_function("STRING-GREATERP", Lstring_greaterp);
603
make_function("STRING-NOT-LESSP", Lstring_not_lessp);
604
make_function("STRING-NOT-GREATERP", Lstring_not_greaterp);
605
make_function("STRING-NOT-EQUAL", Lstring_not_equal);
606
make_function("MAKE-STRING", Lmake_string);
607
make_function("STRING-TRIM", Lstring_trim);
608
make_function("STRING-LEFT-TRIM", Lstring_left_trim);
609
make_function("STRING-RIGHT-TRIM", Lstring_right_trim);
610
make_function("STRING-UPCASE", Lstring_upcase);
611
make_function("STRING-DOWNCASE", Lstring_downcase);
612
make_function("STRING-CAPITALIZE", Lstring_capitalize);
613
make_function("NSTRING-UPCASE", Lnstring_upcase);
614
make_function("NSTRING-DOWNCASE", Lnstring_downcase);
615
make_function("NSTRING-CAPITALIZE", Lnstring_capitalize);
616
make_function("STRING", Lstring);
618
make_si_function("STRING-CONCATENATE",
619
siLstring_concatenate);