← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/string.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2007-04-09 11:51:51 UTC
  • mfrom: (1.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070409115151-ql8cr0kalzx1jmla
Tags: 0.9i-20070324-2
Upload to unstable. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/string.d
20
20
#include <string.h>
21
21
#include <ecl/ecl-inl.h>
22
22
 
 
23
static cl_object
 
24
do_make_base_string(cl_index s, int code)
 
25
{
 
26
        cl_object x = cl_alloc_simple_base_string(s);
 
27
        cl_index i;
 
28
        for (i = 0;  i < s;  i++)
 
29
                x->base_string.self[i] = code;
 
30
        return x;
 
31
}
23
32
 
24
33
#ifdef ECL_UNICODE
25
 
/* TODO: add a special variable to allow make-string to default to base-char rather than character. */
26
 
/* should be @'character' -- FIXME */
 
34
static cl_object
 
35
do_make_string(cl_index s, cl_index code)
 
36
{
 
37
        cl_object x = cl_alloc_simple_extended_string(s);
 
38
        cl_object c = CODE_CHAR(code);
 
39
        cl_index i;
 
40
        for (i = 0;  i < s;  i++)
 
41
                x->string.self[i] = c;
 
42
        return x;
 
43
}
 
44
#else
 
45
#define do_make_string do_make_base_string
 
46
#endif
27
47
 
28
48
@(defun make_string (size &key (initial_element CODE_CHAR(' '))
29
 
                     (element_type @'character')
30
 
                     &aux x)
31
 
        cl_index i, s, code;
 
49
                     (element_type @'character'))
 
50
        cl_index s;
 
51
        cl_object x;
32
52
@
33
 
        /* INV: char_code() checks the type of initial_element() */
34
 
        code = char_code(initial_element);
35
 
        s = object_to_index(size);
36
 
 
37
 
        /* this code should use subtypep */
38
 
        /* handle base-char strings */
 
53
        s = ecl_to_index(size);
 
54
        /* INV: ecl_[base_]char_code() checks the type of initial_element() */
39
55
        if (element_type == @'base-char' || element_type == @'standard-char') {
40
 
                x = cl_alloc_simple_base_string(s);
41
 
                for (i = 0;  i < s;  i++)
42
 
                        x->base_string.self[i] = code;
43
 
                @(return x)
44
 
        }
45
 
 
46
 
        if (element_type != @'character'
47
 
            && (funcall(3, @'subtypep', element_type, @'character') == Cnil))
48
 
            FEerror("The type ~S is not a valid string char type.", 1, element_type);
49
 
 
50
 
        x = cl_alloc_simple_extended_string(s);
51
 
        for (i = 0;  i < s;  i++)
52
 
                x->string.self[i] = CODE_CHAR(code);
53
 
        @(return x)
54
 
@)
55
 
#else
56
 
@(defun make_string (size &key (initial_element CODE_CHAR(' '))
57
 
                     (element_type @'character')
58
 
                     &aux x)
59
 
        cl_index i, s, code;
60
 
@
61
 
        if (element_type != @'character'
62
 
            && element_type != @'base-char'
63
 
            && element_type != @'standard-char') {
64
 
          if (funcall(3, @'subtypep', element_type, @'character') == Cnil)
65
 
            FEerror("The type ~S is not a valid string char type.",
66
 
                    1, element_type);
67
 
        }
68
 
        /* INV: char_code() checks the type of initial_element() */
69
 
        code = char_code(initial_element);
70
 
        s = object_to_index(size);
71
 
        x = cl_alloc_simple_base_string(s);
72
 
        for (i = 0;  i < s;  i++)
73
 
                x->base_string.self[i] = code;
74
 
        @(return x)
75
 
@)
76
 
#endif
 
56
                int code = ecl_base_char_code(initial_element);
 
57
                x = do_make_base_string(s, code);
 
58
        } else if (element_type == @'character') {
 
59
                cl_index code = ecl_char_code(initial_element);
 
60
                x = do_make_string(s, code);
 
61
        } else if (funcall(3, @'subtypep', element_type, @'base-char') == Ct) {
 
62
                int code = ecl_base_char_code(initial_element);
 
63
                x = do_make_base_string(s, code);
 
64
        } else if (funcall(3, @'subtypep', element_type, @'character') == Ct) {
 
65
                cl_index code = ecl_char_code(initial_element);
 
66
                x = do_make_string(s, code);
 
67
        } else {
 
68
                FEerror("The type ~S is not a valid string char type.",
 
69
                        1, element_type);
 
70
        }
 
71
        @(return x)
 
72
@)
77
73
 
78
74
cl_object
79
75
cl_alloc_simple_base_string(cl_index length)
161
157
                return make_base_string_copy(s);
162
158
}
163
159
 
 
160
bool
 
161
ecl_fits_in_base_string(cl_object s)
 
162
{
 
163
 AGAIN:
 
164
        switch (type_of(s)) {
 
165
#ifdef ECL_UNICODE
 
166
        case t_string: {
 
167
                cl_index i;
 
168
                for (i = 0; i < s->string.fillp; i++) {
 
169
                        if (!BASE_CHAR_P(s->string.self[i]))
 
170
                                return 0;
 
171
                }
 
172
                return 1;
 
173
        }
 
174
#endif
 
175
        case t_base_string:
 
176
                return 1;
 
177
        default:
 
178
                s = ecl_type_error(@'si::copy-to-simple-base-string',"",s,@'string');
 
179
                goto AGAIN;
 
180
        }
 
181
}
164
182
 
165
183
cl_object
166
184
si_copy_to_simple_base_string(cl_object x)
194
212
                break;
195
213
        }
196
214
        default:
197
 
                /* This will signal a type error */
198
 
                assert_type_string(x);
 
215
                x = ecl_type_error(@'si::copy-to-simple-base-string',"",x,@'string');
 
216
                goto AGAIN;
199
217
        }
200
218
        @(return y)
201
219
}
203
221
cl_object
204
222
cl_string(cl_object x)
205
223
{
 
224
 AGAIN:
206
225
        switch (type_of(x)) {
207
226
        case t_symbol:
208
227
                x = x->symbol.name;
218
237
                        y = cl_alloc_simple_extended_string(1);
219
238
                        y->string.self[0] = x;
220
239
                        x = y;
221
 
                        }
 
240
                }
222
241
#else
223
242
                y = cl_alloc_simple_base_string(1);
224
243
                y->base_string.self[0] = CHAR_CODE(x);
232
251
        case t_base_string:
233
252
                break;
234
253
        default:
235
 
                FEtype_error_string(x);
 
254
                x = ecl_type_error(@'string',"",x,@'string');
 
255
                goto AGAIN;
236
256
        }
237
257
        @(return x)
238
258
}
272
292
                y = x;
273
293
                break;
274
294
        default:
275
 
                FEtype_error_string(x);
 
295
                x = ecl_type_error(@'si::coerce-to-extended-string',"",x,@'string');
 
296
                goto AGAIN;
276
297
        }
277
298
        @(return y)
278
299
}
281
302
cl_object
282
303
cl_char(cl_object object, cl_object index)
283
304
{
284
 
        cl_index position = object_to_index(index);
 
305
        cl_index position = ecl_to_index(index);
 
306
        @(return CODE_CHAR(ecl_char(object, position)))
 
307
}
 
308
 
 
309
cl_index
 
310
ecl_char(cl_object object, cl_index index)
 
311
{
285
312
        /* CHAR bypasses fill pointers when accessing strings */
286
 
 
 
313
 AGAIN:
287
314
        switch(type_of(object)) {
288
315
#ifdef ECL_UNICODE
289
316
        case t_string:
290
 
                if (position >= object->string.dim)
291
 
                        illegal_index(object, index);
292
 
                @(return object->string.self[position])
 
317
                if (index >= object->string.dim)
 
318
                        FEillegal_index(object, MAKE_FIXNUM(index));
 
319
                return CHAR_CODE(object->string.self[index]);
293
320
#endif
294
321
        case t_base_string:
295
 
                if (position >= object->base_string.dim)
296
 
                        illegal_index(object, index);
297
 
                @(return CODE_CHAR(object->base_string.self[position]))
 
322
                if (index >= object->base_string.dim)
 
323
                        FEillegal_index(object, MAKE_FIXNUM(index));
 
324
                return object->base_string.self[index];
298
325
        default:
299
 
                FEtype_error_string(object);
 
326
                object = ecl_type_error(@'char',"",object,@'string');
 
327
                goto AGAIN;
300
328
        }
301
329
}
302
330
 
303
331
cl_object
304
332
si_char_set(cl_object object, cl_object index, cl_object value)
305
333
{
306
 
        cl_index position = object_to_index(index);
 
334
        cl_index position = ecl_to_index(index);
 
335
        cl_index c = ecl_char_code(value);
 
336
        ecl_char_set(object, position, c);
 
337
        @(return value)
 
338
}
307
339
 
 
340
void
 
341
ecl_char_set(cl_object object, cl_index index, cl_index value)
 
342
{
 
343
 AGAIN:
308
344
        /* CHAR bypasses fill pointers when accessing strings */
309
345
        switch(type_of(object)) {
310
346
#ifdef ECL_UNICODE
311
347
        case t_string:
312
 
                if (position >= object->string.dim)
313
 
                        illegal_index(object, index);
314
 
                if (!CHARACTERP(value)) FEtype_error_character(value);
315
 
                object->string.self[position] = value;
316
 
                @(return object->string.self[position])
 
348
                if (index >= object->string.dim)
 
349
                        FEillegal_index(object, MAKE_FIXNUM(index));
 
350
                object->string.self[index] = CODE_CHAR(value);
 
351
                break;
317
352
#endif
318
353
        case t_base_string:
319
 
                if (position >= object->base_string.dim)
320
 
                        illegal_index(object, index);
321
 
                /* INV: char_code() checks type of value */
322
 
                object->base_string.self[position] = char_code(value);
323
 
                @(return value)
 
354
                if (index >= object->base_string.dim)
 
355
                        FEillegal_index(object, MAKE_FIXNUM(index));
 
356
                /* INV: ecl_char_code() checks type of value */
 
357
                object->base_string.self[index] = value;
 
358
                break;
324
359
        default:
325
 
                FEtype_error_string(object);
 
360
                object = ecl_type_error(@'si::char-set', "", object, @'string');
 
361
                goto AGAIN;
326
362
        }
327
363
}
328
364
 
356
392
 
357
393
#ifdef ECL_UNICODE
358
394
static int
359
 
compare_extended(cl_object *s1, cl_index l1, cl_object *s2, cl_index l2,
360
 
                 int case_sensitive, cl_index *m)
361
 
{
362
 
        cl_index l, c1, c2;
363
 
        for (l = 0; l < l1; l++, s1++, s2++) {
364
 
                if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */
365
 
                        *m = l;
366
 
                        return +1;
367
 
                }
368
 
                c1 = CHAR_CODE(*s1);
369
 
                c2 = CHAR_CODE(*s2);
370
 
                if (!case_sensitive) {
371
 
                        c1 = toupper(c1);
372
 
                        c2 = toupper(c2);
373
 
                }
374
 
                if (c1 < c2) {
375
 
                        *m = l;
376
 
                        return -1;
377
 
                } else if (c1 > c2) {
378
 
                        *m = l;
379
 
                        return +1;
380
 
                }
381
 
        }
382
 
        *m = l;
383
 
        if (l1 == l2)
384
 
                return 0;
385
 
        else { /* s1 is shorter than s2, hence s1 < s2 */
386
 
                return -1;
387
 
        }
388
 
}
389
 
#endif
390
 
 
391
 
#ifdef ECL_UNICODE
392
 
static int
393
 
compare_mixed(cl_object *s1, cl_index l1, char *s2, cl_index l2,
394
 
              int case_sensitive, cl_index *m)
395
 
{
396
 
        cl_index l, c1, c2;
397
 
        for (l = 0; l < l1; l++, s1++, s2++) {
398
 
                if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */
399
 
                        *m = l;
400
 
                        return +1;
401
 
                }
402
 
                c1 = CHAR_CODE(*s1);
403
 
                c2 = *s2;
404
 
                if (!case_sensitive) {
405
 
                        c1 = toupper(c1);
406
 
                        c2 = toupper(c2);
407
 
                }
408
 
                if (c1 < c2) {
409
 
                        *m = l;
410
 
                        return -1;
411
 
                } else if (c1 > c2) {
412
 
                        *m = l;
413
 
                        return +1;
414
 
                }
415
 
        }
416
 
        *m = l;
417
 
        if (l1 == l2)
418
 
                return 0;
419
 
        else { /* s1 is shorter than s2, hence s1 < s2 */
 
395
compare_strings(cl_object string1, cl_index s1, cl_index e1,
 
396
                cl_object string2, cl_index s2, cl_index e2,
 
397
                int case_sensitive, cl_index *m)
 
398
{
 
399
        cl_index c1, c2;
 
400
        for (; s1 < e1; s1++, s2++) {
 
401
                if (s2 >= e2) { /* s1 is longer than s2, therefore s2 < s1 */
 
402
                        *m = s1;
 
403
                        return +1;
 
404
                }
 
405
                c1 = ecl_char(string1, s1);
 
406
                c2 = ecl_char(string2, s2);
 
407
                if (!case_sensitive) {
 
408
                        c1 = towupper(c1);
 
409
                        c2 = towupper(c2);
 
410
                }
 
411
                if (c1 < c2) {
 
412
                        *m = s1;
 
413
                        return -1;
 
414
                } else if (c1 > c2) {
 
415
                        *m = s1;
 
416
                        return +1;
 
417
                }
 
418
        }
 
419
        *m = s1;
 
420
        if (s2 >= e2) {
 
421
                return 0;
 
422
        } else { /* s1 is shorter than s2, hence s1 < s2 */
420
423
                return -1;
421
424
        }
422
425
}
457
460
                                      (start2 MAKE_FIXNUM(0)) end2)
458
461
        cl_index s1, e1, s2, e2;
459
462
@
 
463
  AGAIN:
460
464
        string1 = cl_string(string1);
461
465
        string2 = cl_string(string2);
462
466
        get_string_start_end(string1, start1, end1, &s1, &e1);
463
467
        get_string_start_end(string2, start2, end2, &s2, &e2);
464
468
        if (e1 - s1 != e2 - s2)
465
469
                @(return Cnil)
466
 
 
467
470
#ifdef ECL_UNICODE
468
471
        switch(type_of(string1)) {
469
472
        case t_string:
478
481
                                if (CHAR_CODE(string1->string.self[s1++]) != string2->base_string.self[s2++])
479
482
                                        @(return Cnil)
480
483
                        @(return Ct)
481
 
                default:
482
 
                        FEtype_error_string(string2);
483
484
                }
484
485
                break;
485
486
        case t_base_string:
494
495
                                if (string1->base_string.self[s1++] != string2->base_string.self[s2++])
495
496
                                        @(return Cnil)
496
497
                        @(return Ct)
497
 
                default:
498
 
                        FEtype_error_string(string2);
499
498
                }
500
499
                break;
501
 
        default:
502
 
                FEtype_error_string(string1);
503
 
        }
 
500
        }
504
501
#else
505
502
        while (s1 < e1)
506
503
                if (string1->base_string.self[s1++] !=
514
511
        This correponds to string= (just the string equality).
515
512
*/
516
513
bool
517
 
string_eq(cl_object x, cl_object y)
 
514
ecl_string_eq(cl_object x, cl_object y)
518
515
{
519
516
        cl_index i, j;
 
517
 AGAIN:
520
518
        i = x->base_string.fillp;
521
519
        j = y->base_string.fillp;
522
520
        if (i != j) return 0;
523
521
#ifdef ECL_UNICODE
524
 
AGAIN:
525
522
        switch(type_of(x)) {
526
523
        case t_string:
527
524
                switch(type_of(y)) {
535
532
                        return 1;
536
533
                        }
537
534
                default:
538
 
                        FEtype_error_string(y);
 
535
                        y = ecl_type_error(@'string=',"",y,@'string');
 
536
                        goto AGAIN;
539
537
                }
540
538
                break;
541
539
        case t_base_string:
542
540
                switch(type_of(y)) {
543
 
                case t_string: {
544
 
                        cl_object z = x; x = y; y = z;
545
 
                        goto AGAIN;
546
 
                }
 
541
                case t_string:
 
542
                        return ecl_string_eq(y, x);
547
543
                case t_base_string:
548
544
                        return memcmp(x->base_string.self, y->base_string.self, i) == 0;
549
545
                default:
550
 
                        FEtype_error_string(y);
 
546
                        y = ecl_type_error(@'string=',"",y,@'string');
 
547
                        goto AGAIN;
551
548
                }
552
549
                break;
553
550
        default:
554
 
                FEtype_error_string(x);
 
551
                x = ecl_type_error(@'string=',"",x,@'string');
 
552
                goto AGAIN;
555
553
        }
556
554
#else
557
555
        return memcmp(x->base_string.self, y->base_string.self, i) == 0;
564
562
        cl_index s1, e1, s2, e2;
565
563
        int output;
566
564
@
 
565
AGAIN:
567
566
        string1 = cl_string(string1);
568
567
        string2 = cl_string(string2);
569
568
        get_string_start_end(string1, start1, end1, &s1, &e1);
570
569
        get_string_start_end(string2, start2, end2, &s2, &e2);
571
570
        if (e1 - s1 != e2 - s2)
572
 
                @(return Cnil)
 
571
                @(return Cnil);
573
572
#ifdef ECL_UNICODE
574
 
        switch(type_of(string1)) {
575
 
        case t_string:
576
 
                switch(type_of(string2)) {
577
 
                case t_string:
578
 
                        output = compare_extended(string1->string.self + s1, e1 - s1,
579
 
                                                  string2->string.self + s2, e2 - s2,
580
 
                                                  0, &e1);
581
 
                        break;
582
 
                case t_base_string:
583
 
                        output = compare_mixed(string1->string.self + s1, e1 - s1,
584
 
                                               string2->base_string.self + s2, e2 - s2,
585
 
                                               0, &e1);
586
 
                        break;
587
 
                default:
588
 
                        FEtype_error_string(string2);
589
 
                }
590
 
                break;
591
 
        case t_base_string:
592
 
                switch(type_of(string2)) {
593
 
                case t_string:
594
 
                        output = compare_mixed(string2->string.self + s2, e2 - s2,
595
 
                                               string1->base_string.self + s1, e1 - s1,
596
 
                                               0, &e1);
597
 
                        break;
598
 
                case t_base_string:
599
 
                        output = compare_base(string1->base_string.self + s1, e1 - s1,
600
 
                                              string2->base_string.self + s2, e2 - s2,
601
 
                                              0, &e1);
602
 
                        break;
603
 
                default:
604
 
                        FEtype_error_string(string2);
605
 
                }
606
 
                break;
607
 
        default:
608
 
                FEtype_error_string(string1);
609
 
        }
610
 
#else
 
573
        if (type_of(string1) != t_base_string || type_of(string2) != t_base_string) {
 
574
                output = compare_strings(string1, s1, e1, string2, s2, e2, 0, &e1);
 
575
        } else
 
576
#endif
611
577
        output = compare_base(string1->base_string.self + s1, e1 - s1,
612
578
                              string2->base_string.self + s2, e2 - s2,
613
579
                              0, &e1);
614
 
#endif
615
580
        @(return ((output == 0)? Ct : Cnil))
616
581
@)
617
582
 
646
611
        get_string_start_end(string1, start1, end1, &s1, &e1);
647
612
        get_string_start_end(string2, start2, end2, &s2, &e2);
648
613
#ifdef ECL_UNICODE
649
 
        switch(type_of(string1)) {
650
 
        case t_string:
651
 
                switch(type_of(string2)) {
652
 
                case t_string:
653
 
                        output = compare_extended(string1->string.self + s1, e1 - s1,
654
 
                                                  string2->string.self + s2, e2 - s2,
655
 
                                                  case_sensitive, &e1);
656
 
                        break;
657
 
                case t_base_string:
658
 
                        output = compare_mixed(string1->string.self + s1, e1 - s1,
659
 
                                               string2->base_string.self + s2, e2 - s2,
660
 
                                               case_sensitive, &e1);
661
 
                        break;
662
 
                }
663
 
        case t_base_string:
664
 
                switch(type_of(string2)) {
665
 
                case t_string:
666
 
                        output = compare_mixed(string2->string.self + s2, e2 - s2,
667
 
                                               string1->base_string.self + s1, e1 - s1,
668
 
                                               case_sensitive, &e1);
669
 
                        output = - output;
670
 
                        break;
671
 
                case t_base_string:
672
 
                        output = compare_base(string1->base_string.self + s1, e1 - s1,
673
 
                                              string2->base_string.self + s2, e2 - s2,
674
 
                                              case_sensitive, &e1);
675
 
                        break;
676
 
                }
 
614
        if (type_of(string1) != t_base_string || type_of(string2) != t_base_string) {
 
615
                output = compare_strings(string1, s1, e1, string2, s2, e2,
 
616
                                         case_sensitive, &e1);
 
617
        } else
 
618
#endif
 
619
        {
 
620
                output = compare_base(string1->base_string.self + s1, e1 - s1,
 
621
                                      string2->base_string.self + s2, e2 - s2,
 
622
                                      case_sensitive, &e1);
 
623
                e1 += s1;
677
624
        }
678
 
#else
679
 
        output = compare_base(string1->base_string.self + s1, e1 - s1,
680
 
                              string2->base_string.self + s2, e2 - s2,
681
 
                              case_sensitive, &e1);
682
 
#endif
683
625
        if (output == sign1 || output == sign2) {
684
 
                result = MAKE_FIXNUM(e1 + s1);
 
626
                result = MAKE_FIXNUM(e1);
685
627
        } else {
686
628
                result = Cnil;
687
629
        }
745
687
@)
746
688
 
747
689
bool
748
 
member_char(int c, cl_object char_bag)
 
690
ecl_member_char(int c, cl_object char_bag)
749
691
{
750
692
        cl_index i, f;
751
 
 
 
693
 AGAIN:
752
694
        switch (type_of(char_bag)) {
753
695
        case t_cons:
754
696
                loop_for_in(char_bag) {
757
699
                                return(TRUE);
758
700
                } end_loop_for_in;
759
701
                return(FALSE);
760
 
 
761
702
        case t_vector:
762
703
                for (i = 0, f = char_bag->vector.fillp;  i < f;  i++) {
763
704
                        cl_object other = char_bag->vector.self.t[i];
765
706
                                return(TRUE);
766
707
                }
767
708
                return(FALSE);
768
 
 
769
709
#ifdef ECL_UNICODE
770
710
        case t_string:
771
711
                for (i = 0, f = char_bag->string.fillp;  i < f;  i++) {
774
714
                }
775
715
                return(FALSE);
776
716
#endif
777
 
 
778
717
        case t_base_string:
779
718
                for (i = 0, f = char_bag->base_string.fillp;  i < f;  i++) {
780
719
                        if (c == char_bag->base_string.self[i])
781
720
                                return(TRUE);
782
721
                }
783
722
                return(FALSE);
784
 
 
785
723
        case t_bitvector:
786
724
                return(FALSE);
787
 
 
788
725
        case t_symbol:
789
726
                if (Null(char_bag))
790
727
                        return(FALSE);
791
 
                FEwrong_type_argument(@'sequence', char_bag);
792
 
 
 
728
                /* falls through */
793
729
        default:
794
 
                FEwrong_type_argument(@'sequence', char_bag);
 
730
                char_bag = ecl_type_error(@'member',"",char_bag,@'sequence');
 
731
                goto AGAIN;
795
732
        }
796
733
}
797
734
 
798
735
static cl_object
799
736
string_trim0(bool left_trim, bool right_trim, cl_object char_bag, cl_object strng)
800
737
{
801
 
        cl_object res;
802
 
        cl_index i, j, k;
 
738
        cl_index i, j;
803
739
 
804
740
        strng = cl_string(strng);
805
741
        i = 0;
806
 
        j = strng->base_string.fillp - 1;
807
 
        if (left_trim)
808
 
                for (;  i <= j;  i++)
809
 
                        if (!member_char(strng->base_string.self[i], char_bag))
810
 
                                break;
811
 
        if (right_trim)
812
 
                for (;  j >= i;  --j)
813
 
                        if (!member_char(strng->base_string.self[j], char_bag))
814
 
                                break;
815
 
        k = j - i + 1;
816
 
        res = cl_alloc_simple_base_string(k);
817
 
        memcpy(res->base_string.self, strng->base_string.self+i, k);
818
 
        @(return res)
 
742
        j = ecl_length(strng);
 
743
        if (left_trim) {
 
744
                for (;  i < j;  i++) {
 
745
                        cl_index c = ecl_char(strng, i);
 
746
                        if (!ecl_member_char(c, char_bag))
 
747
                                break;
 
748
                }
 
749
        }
 
750
        if (right_trim) {
 
751
                for (; j > i; j--) {
 
752
                        cl_index c = ecl_char(strng, j-1);
 
753
                        if (!ecl_member_char(c, char_bag)) {
 
754
                                break;
 
755
                        }
 
756
                }
 
757
        }
 
758
        return cl_subseq(3, strng, MAKE_FIXNUM(i), MAKE_FIXNUM(j));
819
759
}
820
760
 
821
761
cl_object
926
866
@)
927
867
 
928
868
 
929
 
#ifdef ECL_UNICODE
930
869
static cl_object
931
 
nstring_case(cl_narg narg, int (*casefun)(int, bool *), cl_va_list ARGS)
 
870
nstring_case(cl_narg narg, cl_object fun, int (*casefun)(int, bool *), cl_va_list ARGS)
932
871
{
933
872
        cl_object strng = cl_va_arg(ARGS);
934
873
        cl_index s, e, i;
944
883
        KEYS[1]=@':end';
945
884
        cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE);
946
885
 
947
 
        assert_type_string(strng);
 
886
        strng = ecl_check_type_string(fun,strng);
948
887
        if (startp == Cnil) start = MAKE_FIXNUM(0);
949
888
        get_string_start_end(strng, start, end, &s, &e);
950
889
        b = TRUE;
951
 
        switch(type_of(strng)) {
952
 
        case t_string:
 
890
#ifdef ECL_UNICODE
 
891
        if (type_of(strng) == t_string) {
953
892
                for (i = s;  i < e;  i++)
954
893
                        strng->string.self[i] = CODE_CHAR((*casefun)(CHAR_CODE(strng->string.self[i]), &b));
955
 
                break;
956
 
        case t_base_string:
 
894
        } else {
957
895
                for (i = s;  i < e;  i++)
958
896
                        strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b);
959
 
                break;
960
897
        }
961
 
        @(return strng)
962
 
#undef startp
963
 
#undef start
964
 
#undef end
965
 
}
966
898
#else
967
 
static cl_object
968
 
nstring_case(cl_narg narg, int (*casefun)(int, bool *), cl_va_list ARGS)
969
 
{
970
 
        cl_object strng = cl_va_arg(ARGS);
971
 
        cl_index s, e, i;
972
 
        bool b;
973
 
        cl_object KEYS[2];
974
 
#define start KEY_VARS[0]
975
 
#define end KEY_VARS[1]
976
 
#define startp KEY_VARS[2]
977
 
        cl_object KEY_VARS[4];
978
 
 
979
 
        if (narg < 1) FEwrong_num_arguments_anonym();
980
 
        KEYS[0]=@':start';
981
 
        KEYS[1]=@':end';
982
 
        cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE);
983
 
 
984
 
        assert_type_base_string(strng);
985
 
        if (startp == Cnil) start = MAKE_FIXNUM(0);
986
 
        get_string_start_end(strng, start, end, &s, &e);
987
 
        b = TRUE;
988
899
        for (i = s;  i < e;  i++)
989
900
                strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b);
 
901
#endif
990
902
        @(return strng)
991
903
#undef startp
992
904
#undef start
993
905
#undef end
994
906
}
995
 
#endif
996
907
 
997
908
@(defun nstring-upcase (&rest args)
998
909
@
999
 
        return nstring_case(narg, char_upcase, args);
 
910
        return nstring_case(narg, @'nstring-upcase', char_upcase, args);
1000
911
@)
1001
912
 
1002
913
@(defun nstring-downcase (&rest args)
1003
914
@
1004
 
        return nstring_case(narg, char_downcase, args);
 
915
        return nstring_case(narg, @'nstring-downcase', char_downcase, args);
1005
916
@)
1006
917
 
1007
918
@(defun nstring-capitalize (&rest args)
1008
919
@
1009
 
        return nstring_case(narg, char_capitalize, args);
 
920
        return nstring_case(narg, @'nstring-capitalize', char_capitalize, args);
1010
921
@)
1011
922
 
1012
923
@(defun si::base_string_concatenate (&rest args)
1013
924
        cl_index l;
1014
925
        int i;
1015
 
        char *vself;
1016
 
#ifdef __GNUC__
1017
 
        cl_object v, strings[narg];
1018
 
#else
1019
 
#define NARG_MAX 64
1020
 
        cl_object v, strings[NARG_MAX];
1021
 
#endif
1022
 
@
1023
 
#ifndef __GNUC__
1024
 
        if (narg > NARG_MAX)
1025
 
                FEerror("si::string_concatenate: Too many arguments, limited to ~A", 1, MAKE_FIXNUM(NARG_MAX));
1026
 
#endif
1027
 
        /* FIXME! We should use cl_va_start() instead of this ugly trick */
1028
 
        for (i = 0, l = 0;  i < narg;  i++) {
1029
 
                strings[i] = si_coerce_to_base_string(cl_va_arg(args));
1030
 
                l += strings[i]->base_string.fillp;
1031
 
        }
1032
 
        v = cl_alloc_simple_base_string(l);
1033
 
        for (i = 0, vself = v->base_string.self;  i < narg;  i++, vself += l) {
1034
 
                l = strings[i]->base_string.fillp;
1035
 
                memcpy(vself, strings[i]->base_string.self, l);
1036
 
        }
1037
 
        @(return v)
1038
 
@)
1039
 
 
1040
 
#ifdef ECL_UNICODE
1041
 
@(defun si::extended_string_concatenate (&rest args)
1042
 
        cl_index l;
1043
 
        int i;
1044
 
        char *vself;
1045
 
#ifdef __GNUC__
1046
 
        cl_object v, strings[narg];
1047
 
#else
1048
 
#define NARG_MAX 64
1049
 
        cl_object v, strings[NARG_MAX];
1050
 
#endif
1051
 
@
1052
 
#ifndef __GNUC__
1053
 
        if (narg > NARG_MAX)
1054
 
                FEerror("si::string_concatenate: Too many arguments, limited to ~A", 1, MAKE_FIXNUM(NARG_MAX));
1055
 
#endif
1056
 
        /* FIXME! We should use cl_va_start() instead of this ugly trick */
1057
 
        for (i = 0, l = 0;  i < narg;  i++) {
1058
 
                strings[i] = si_coerce_to_extended_string(cl_va_arg(args));
1059
 
                l += strings[i]->string.fillp;
1060
 
        }
1061
 
        v = cl_alloc_simple_extended_string(l);
1062
 
        for (i = 0, vself = v->string.self;  i < narg;  i++, vself += l) {
1063
 
                l = strings[i]->string.fillp;
1064
 
                memcpy(vself, strings[i]->string.self, l);
1065
 
        }
1066
 
        @(return v)
1067
 
@)
1068
 
#endif
1069
 
 
1070
 
#ifdef ECL_UNICODE
 
926
        cl_object output;
 
927
@
 
928
        /* Compute final size and store NONEMPTY coerced strings. */
 
929
        for (i = 0, l = 0; i < narg; i++) {
 
930
                cl_object s = si_coerce_to_base_string(cl_va_arg(args));
 
931
                if (s->base_string.fillp) {
 
932
                        cl_stack_push(s);
 
933
                        l += s->base_string.fillp;
 
934
                }
 
935
        }
 
936
        /* Do actual copying by recovering those strings */
 
937
        output = cl_alloc_simple_base_string(l);
 
938
        while (l) {
 
939
                cl_object s = cl_stack_pop();
 
940
                size_t bytes = s->base_string.fillp;
 
941
                l -= bytes;
 
942
                memcpy(output->base_string.self + l, s->base_string.self, bytes);
 
943
        }
 
944
        @(return output);
 
945
@)
 
946
 
1071
947
int
1072
948
ecl_string_push_extend(cl_object s, int c)
1073
949
{
1074
 
        cl_index new_length;
1075
 
 
 
950
 AGAIN:
1076
951
        switch(type_of(s)) {
 
952
#ifdef ECL_UNICODE
1077
953
        case t_string:
1078
 
                if (s->string.fillp >= s->string.dim) {
1079
 
                        cl_object *p;
1080
 
                        if (!s->string.adjustable)
1081
 
                                FEerror("string-push-extend: the string ~S is not adjustable.",
1082
 
                                        1, s);
1083
 
                        start_critical_section(); /* avoid losing p */
1084
 
                        if (s->string.dim >= ADIMLIM/2)
1085
 
                                FEerror("Can't extend the string.", 0);
1086
 
                        new_length = (s->string.dim + 1) * 2;
1087
 
                        p = (cl_object *)cl_alloc_align(sizeof (cl_object)*new_length, sizeof (cl_object));
1088
 
                        memcpy(p, s->string.self, s->string.dim * sizeof (cl_object));
1089
 
                        s->string.dim = new_length;
1090
 
                        adjust_displaced(s, p - s->string.self);
1091
 
                        end_critical_section();
1092
 
                }
1093
 
                s->string.self[s->string.fillp++] = CODE_CHAR(c);
1094
 
                return c;
 
954
#endif
1095
955
        case t_base_string:
 
956
                /* We use the fact that both string types are
 
957
                   byte-compatible except for the data. */
1096
958
                if (s->base_string.fillp >= s->base_string.dim) {
1097
 
                        char *p;
 
959
                        cl_object other;
 
960
                        cl_index new_length;
1098
961
                        if (!s->base_string.adjustable)
1099
962
                                FEerror("string-push-extend: the string ~S is not adjustable.",
1100
963
                                        1, s);
1101
 
                        start_critical_section(); /* avoid losing p */
1102
 
                        if (s->base_string.dim >= ADIMLIM/2)
 
964
                        if (s->base_string.dim >= ADIMLIM)
1103
965
                                FEerror("Can't extend the string.", 0);
1104
 
                        new_length = (s->base_string.dim + 1) * 2;
1105
 
                        p = (char *)cl_alloc_atomic(new_length+1); p[new_length] = 0;
1106
 
                        memcpy(p, s->base_string.self, s->base_string.dim * sizeof(char));
1107
 
                        s->base_string.dim = new_length;
1108
 
                        adjust_displaced(s, p - (char *)s->base_string.self);
1109
 
                        end_critical_section();
 
966
                        new_length = 1 + s->base_string.dim + (s->base_string.dim / 2);
 
967
                        if (new_length > ADIMLIM)
 
968
                                new_length = ADIMLIM;
 
969
                        other = si_make_vector(cl_array_element_type(s),
 
970
                                               MAKE_FIXNUM(new_length), Ct,
 
971
                                               MAKE_FIXNUM(s->base_string.fillp),
 
972
                                               Cnil, MAKE_FIXNUM(0));
 
973
                        ecl_copy_subarray(other, 0, s, 0, s->base_string.fillp);
 
974
                        s = si_replace_array(s, other);
1110
975
                }
1111
 
                s->base_string.self[s->base_string.fillp++] = c;
 
976
                ecl_char_set(s, s->base_string.fillp++, c);
1112
977
                return c;
1113
978
        default:
1114
 
                FEtype_error_string(s);
1115
 
        }
1116
 
}
1117
 
#else
1118
 
int
1119
 
ecl_string_push_extend(cl_object s, int c)
1120
 
{
1121
 
        char *p;
1122
 
        cl_index new_length;
1123
 
 
1124
 
        if (type_of(s) != t_base_string) {
1125
 
                FEtype_error_string(s);
1126
 
        } else if (s->base_string.fillp >= s->base_string.dim) {
1127
 
                if (!s->base_string.adjustable)
1128
 
                        FEerror("string-push-extend: the string ~S is not adjustable.",
1129
 
                                1, s);
1130
 
                start_critical_section(); /* avoid losing p */
1131
 
                if (s->base_string.dim >= ADIMLIM/2)
1132
 
                        FEerror("Can't extend the string.", 0);
1133
 
                new_length = (s->base_string.dim + 1) * 2;
1134
 
                p = (char *)cl_alloc_atomic(new_length+1); p[new_length] = 0;
1135
 
                memcpy(p, s->base_string.self, s->base_string.dim * sizeof(char));
1136
 
                s->base_string.dim = new_length;
1137
 
                adjust_displaced(s, p - (char *)s->base_string.self);
1138
 
                end_critical_section();
1139
 
        }
1140
 
        s->base_string.self[s->base_string.fillp++] = c;
1141
 
        return c;
1142
 
}
1143
 
#endif
 
979
                s = ecl_type_error(@'vector-push-extend',"",s,@'string');
 
980
                goto AGAIN;
 
981
        }
 
982
}