← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/c/character.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/character.d
 
1
/*
 
2
    character.d -- Character routines.
 
3
*/
 
4
/*
 
5
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 
6
    Copyright (c) 1990, Giuseppe Attardi.
 
7
 
 
8
    ECL is free software; you can redistribute it and/or
 
9
    modify it under the terms of the GNU Library General Public
 
10
    License as published by the Free Software Foundation; either
 
11
    version 2 of the License, or (at your option) any later version.
 
12
 
 
13
    See file '../Copyright' for full details.
 
14
*/
 
15
 
 
16
 
 
17
#include <ecl/ecl.h>
 
18
#include <ctype.h>
 
19
 
 
20
cl_fixnum
 
21
char_code(cl_object c)
 
22
{
 
23
        if (CHARACTERP(c))
 
24
                return CHAR_CODE(c);
 
25
        FEtype_error_character(c);
 
26
}
 
27
 
 
28
cl_object
 
29
cl_standard_char_p(cl_object c)
 
30
{
 
31
        /* INV: char_code() checks the type */
 
32
        cl_fixnum i = char_code(c);
 
33
        @(return (((' ' <= i && i < '\177') || i == '\n')? Ct : Cnil))
 
34
}
 
35
 
 
36
cl_object
 
37
cl_graphic_char_p(cl_object c)
 
38
{
 
39
        /* INV: char_code() checks the type */
 
40
        cl_fixnum i = char_code(c);     /* ' ' < '\177'  ??? Beppe*/
 
41
        @(return ((' ' <= i && i < '\177')? Ct : Cnil))
 
42
}
 
43
 
 
44
cl_object
 
45
cl_alpha_char_p(cl_object c)
 
46
{
 
47
        /* INV: char_code() checks the type */
 
48
        cl_fixnum i = char_code(c);
 
49
        @(return (isalpha(i)? Ct : Cnil))
 
50
}
 
51
 
 
52
cl_object
 
53
cl_upper_case_p(cl_object c)
 
54
{
 
55
        /* INV: char_code() checks the type */
 
56
        @(return (isupper(char_code(c))? Ct : Cnil))
 
57
}
 
58
 
 
59
cl_object
 
60
cl_lower_case_p(cl_object c)
 
61
{
 
62
        /* INV: char_code() checks the type */
 
63
        @(return (islower(char_code(c))? Ct : Cnil))
 
64
}
 
65
 
 
66
cl_object
 
67
cl_both_case_p(cl_object c)
 
68
{
 
69
        /* INV: char_code() checks the type */
 
70
        cl_fixnum code = char_code(c);
 
71
        @(return ((isupper(code) || islower(code)) ? Ct : Cnil))
 
72
}
 
73
 
 
74
int
 
75
ecl_string_case(cl_object s)
 
76
{
 
77
        int upcase;
 
78
        cl_index i;
 
79
        const char *text;
 
80
        for (i = 0, upcase = 0, text = s->string.self; i <= s->string.dim; i++) {
 
81
                if (isupper(text[i])) {
 
82
                        if (upcase < 0)
 
83
                                return 0;
 
84
                        upcase = +1;
 
85
                } else if (islower(text[i])) {
 
86
                        if (upcase > 0)
 
87
                                return 0;
 
88
                        upcase = -1;
 
89
                }
 
90
        }
 
91
        return upcase;
 
92
}
 
93
 
 
94
#define basep(d)        (d <= 36)
 
95
 
 
96
@(defun digit_char_p (c &optional (r MAKE_FIXNUM(10)))
 
97
        cl_object output;
 
98
@
 
99
        /* INV: char_code() checks `c' and fixnnint() checks `r' */
 
100
        if (type_of(r) == t_bignum) {
 
101
                output = Cnil;
 
102
        } else {
 
103
                cl_fixnum d = fixnnint(r);
 
104
                if (!basep(d) || (d = digitp(char_code(c), d)) < 0)
 
105
                        output = Cnil;
 
106
                else
 
107
                        output = MAKE_FIXNUM(d);
 
108
        }
 
109
        @(return output)
 
110
@)
 
111
 
 
112
/*
 
113
        Digitp(i, r) returns the weight of code i
 
114
        as a digit of radix r, which must be 1 < r <= 36.
 
115
        If i is not a digit, -1 is returned.
 
116
*/
 
117
int
 
118
digitp(int i, int r)
 
119
{
 
120
        if (('0' <= i) && (i <= '9') && (i < '0' + r))
 
121
                return(i - '0');
 
122
        if (('A' <= i) && (10 < r) && (i < 'A' + (r - 10)))
 
123
                return(i - 'A' + 10);
 
124
        if (('a' <= i) && (10 < r) && (i < 'a' + (r - 10)))
 
125
                return(i - 'a' + 10);
 
126
        return(-1);
 
127
}
 
128
 
 
129
cl_object
 
130
cl_alphanumericp(cl_object c)
 
131
{
 
132
        /* INV: char_code() checks type of `c' */
 
133
        cl_fixnum i = char_code(c);
 
134
        @(return (isalnum(i)? Ct : Cnil))
 
135
}
 
136
 
 
137
@(defun char= (c &rest cs)
 
138
@
 
139
        /* INV: char_eq() checks types of `c' and `cs' */
 
140
        while (--narg)
 
141
                if (!char_eq(c, cl_va_arg(cs)))
 
142
                        @(return Cnil)
 
143
        @(return Ct)
 
144
@)
 
145
 
 
146
bool
 
147
char_eq(cl_object x, cl_object y)
 
148
{
 
149
        return char_code(x) == char_code(y);
 
150
}
 
151
 
 
152
@(defun char/= (&rest cs)
 
153
        int i, j;
 
154
        cl_object c;
 
155
@
 
156
        /* INV: char_eq() checks types of its arguments */
 
157
        if (narg == 0)
 
158
                FEwrong_num_arguments(@'char/=');
 
159
        c = cl_va_arg(cs);
 
160
        for (i = 2; i<=narg; i++) {
 
161
                cl_va_list ds;
 
162
                cl_va_start(ds, narg, narg, 0);
 
163
                c = cl_va_arg(cs);
 
164
                for (j = 1; j<i; j++)
 
165
                        if (char_eq(cl_va_arg(ds), c))
 
166
                                @(return Cnil)
 
167
        }
 
168
        @(return Ct)
 
169
@)
 
170
 
 
171
static cl_object
 
172
Lchar_cmp(cl_narg narg, int s, int t, cl_va_list args)
 
173
{
 
174
        cl_object c, d;
 
175
 
 
176
        if (narg == 0)
 
177
                FEwrong_num_arguments_anonym();
 
178
        c = cl_va_arg(args);
 
179
        for (; --narg; c = d) {
 
180
                d = cl_va_arg(args);
 
181
                if (s*char_cmp(d, c) < t)
 
182
                        @(return Cnil)
 
183
        }
 
184
        @(return Ct)
 
185
}
 
186
 
 
187
int
 
188
char_cmp(cl_object x, cl_object y)
 
189
{
 
190
        /* char_code(x) returns an integer which is well in the range
 
191
         * of positive fixnums. Therefore, this subtraction never
 
192
         * oveflows. */
 
193
        return char_code(x) - char_code(y);
 
194
}
 
195
 
 
196
@(defun char< (&rest args)
 
197
@
 
198
        return Lchar_cmp(narg, 1, 1, args);
 
199
@)
 
200
 
 
201
@(defun char> (&rest args)
 
202
@
 
203
        return Lchar_cmp(narg,-1, 1, args);
 
204
@)
 
205
 
 
206
@(defun char<= (&rest args)
 
207
@
 
208
        return Lchar_cmp(narg, 1, 0, args);
 
209
@)
 
210
 
 
211
@(defun char>= (&rest args)
 
212
@
 
213
        return Lchar_cmp(narg,-1, 0, args);
 
214
@)
 
215
 
 
216
@(defun char_equal (c &rest cs)
 
217
        int i;
 
218
@
 
219
        /* INV: char_equal() checks the type of its arguments */
 
220
        for (narg--, i = 0;  i < narg;  i++) {
 
221
                if (!char_equal(c, cl_va_arg(cs)))
 
222
                        @(return Cnil)
 
223
        }
 
224
        @(return Ct)
 
225
@)
 
226
 
 
227
bool
 
228
char_equal(cl_object x, cl_object y)
 
229
{
 
230
        cl_fixnum i = char_code(x);
 
231
        cl_fixnum j = char_code(y);
 
232
 
 
233
        if (islower(i))
 
234
                i = toupper(i);
 
235
        if (islower(j))
 
236
                j = toupper(j);
 
237
        return(i == j);
 
238
}
 
239
 
 
240
@(defun char-not-equal (&rest cs)
 
241
        int i, j;
 
242
        cl_object c;
 
243
@
 
244
        /* INV: char_equal() checks the type of its arguments */
 
245
        if (narg == 0)
 
246
                FEwrong_num_arguments(@'char-not-equal');
 
247
        c = cl_va_arg(cs);
 
248
        for (i = 2;  i<=narg;  i++) {
 
249
                cl_va_list ds;
 
250
                cl_va_start(ds, narg, narg, 0);
 
251
                c = cl_va_arg(cs);
 
252
                for (j=1;  j<i;  j++)
 
253
                        if (char_equal(c, cl_va_arg(ds)))
 
254
                                @(return Cnil)
 
255
        }
 
256
        @(return Ct)
 
257
@)
 
258
 
 
259
static cl_object
 
260
Lchar_compare(cl_narg narg, int s, int t, cl_va_list args)
 
261
{
 
262
        cl_object c, d;
 
263
 
 
264
        /* INV: char_compare() checks the types of its arguments */
 
265
        if (narg == 0)
 
266
                FEwrong_num_arguments_anonym();
 
267
        c = cl_va_arg(args);
 
268
        for (; --narg; c = d) {
 
269
                d = cl_va_arg(args);
 
270
                if (s*char_compare(d, c) < t)
 
271
                        @(return Cnil)
 
272
        }
 
273
        @(return Ct)
 
274
}
 
275
 
 
276
int
 
277
char_compare(cl_object x, cl_object y)
 
278
{
 
279
        cl_fixnum i = char_code(x);
 
280
        cl_fixnum j = char_code(y);
 
281
 
 
282
        if (islower(i))
 
283
                i = toupper(i);
 
284
        if (islower(j))
 
285
                j = toupper(j);
 
286
        if (i < j)
 
287
                return(-1);
 
288
        else if (i == j)
 
289
                return(0);
 
290
        else
 
291
                return(1);
 
292
}
 
293
 
 
294
@(defun char-lessp (&rest args)
 
295
@
 
296
        return Lchar_compare(narg, 1, 1, args);
 
297
@)
 
298
 
 
299
@(defun char-greaterp (&rest args)
 
300
@
 
301
        return Lchar_compare(narg,-1, 1, args);
 
302
@)
 
303
 
 
304
@(defun char-not-greaterp (&rest args)
 
305
@
 
306
        return Lchar_compare(narg, 1, 0, args);
 
307
@)
 
308
 
 
309
@(defun char-not-lessp (&rest args)
 
310
@
 
311
        return Lchar_compare(narg,-1, 0, args);
 
312
@)
 
313
 
 
314
 
 
315
cl_object
 
316
cl_character(cl_object x)
 
317
{
 
318
        switch (type_of(x)) {
 
319
        case t_character:
 
320
                break;
 
321
        case t_symbol:
 
322
                x = x->symbol.name;
 
323
        case t_string:
 
324
                if (x->string.fillp == 1)
 
325
                        x = CODE_CHAR(x->string.self[0]);
 
326
                break;
 
327
        default:
 
328
                FEtype_error_character(x);
 
329
        }
 
330
        @(return x)
 
331
}
 
332
 
 
333
cl_object
 
334
cl_char_code(cl_object c)
 
335
{
 
336
        /* INV: char_code() checks the type of `c' */
 
337
        @(return MAKE_FIXNUM(char_code(c)))
 
338
}
 
339
 
 
340
cl_object
 
341
cl_code_char(cl_object c)
 
342
{
 
343
        cl_fixnum fc;
 
344
 
 
345
        switch (type_of(c)) {
 
346
        case t_fixnum:
 
347
                fc = fix(c);
 
348
                if (fc < CHAR_CODE_LIMIT && fc >= 0) {
 
349
                        c = CODE_CHAR(fc);
 
350
                        break;
 
351
                }
 
352
        case t_bignum:
 
353
                c = Cnil;
 
354
                break;
 
355
        default:
 
356
                FEtype_error_integer(c);
 
357
        }
 
358
        @(return c)
 
359
}
 
360
 
 
361
cl_object
 
362
cl_char_upcase(cl_object c)
 
363
{
 
364
        /* INV: char_code() checks the type of `c' */
 
365
        cl_fixnum code = char_code(c);
 
366
        @(return (islower(code) ? CODE_CHAR(toupper(code)) : c))
 
367
}
 
368
 
 
369
cl_object
 
370
cl_char_downcase(cl_object c)
 
371
{
 
372
        /* INV: char_code() checks the type of `c' */
 
373
        cl_fixnum code = char_code(c);
 
374
        @(return (isupper(code) ? CODE_CHAR(tolower(code)) : c))
 
375
}
 
376
 
 
377
@(defun digit_char (w &optional (r MAKE_FIXNUM(10)))
 
378
        cl_object output;
 
379
@
 
380
        /* INV: fixnnint() checks the types of `w' and `r' */
 
381
        if (type_of(w) == t_bignum) {
 
382
                output = Cnil;
 
383
        } else {
 
384
                int dw = ecl_digit_char(fixnnint(w), fixnnint(r));
 
385
                output = (dw < 0)? Cnil : CODE_CHAR(dw);
 
386
        }
 
387
        @(return output)
 
388
@)
 
389
 
 
390
short
 
391
ecl_digit_char(cl_fixnum w, cl_fixnum r)
 
392
{
 
393
        if (r < 2 || r > 36 || w < 0 || w >= r)
 
394
                return(-1);
 
395
        if (w < 10)
 
396
                return(w + '0');
 
397
        else
 
398
                return(w - 10 + 'A');
 
399
}
 
400
 
 
401
cl_object
 
402
cl_char_int(cl_object c)
 
403
{
 
404
        /* INV: char_code() checks the type of `c' */
 
405
        return1(MAKE_FIXNUM(char_code(c)));
 
406
}
 
407
 
 
408
cl_object
 
409
cl_char_name(cl_object c)
 
410
{
 
411
        cl_index code = char_code(c);
 
412
        cl_object output;
 
413
        if (code > 127) {
 
414
                char name[] = "A00";
 
415
                name[2] = ecl_digit_char(code & 0xF, 16);
 
416
                name[1] = ecl_digit_char(code / 16, 16);
 
417
                output = make_string_copy(name);
 
418
        } else {
 
419
                output = gethash_safe(c, cl_core.char_names, Cnil);
 
420
        }
 
421
        @(return output);
 
422
}
 
423
 
 
424
cl_object
 
425
cl_name_char(cl_object name)
 
426
{
 
427
        cl_object c = gethash_safe((name = cl_string(name)), cl_core.char_names, Cnil);
 
428
        if (c == Cnil && length(name) == 3) {
 
429
                char *s = name->string.self;
 
430
                if (s[0] == 'A' || s[0] == 'a') {
 
431
                        int d2 = digitp(s[2], 16);
 
432
                        int d1 = digitp(s[1], 16);
 
433
                        if (d1 >= 0 && d2 >= 0) {
 
434
                                c = CODE_CHAR(d1 * 16 + d2);
 
435
                        }
 
436
                }
 
437
        }
 
438
        @(return c);
 
439
}