source: branches/1.1.x/src/org/armedbear/lisp/StringFunctions.java

Last change on this file was 12513, checked in by ehuelsmann, 15 years ago

Remove 'private' keyword to eliminate the Java requirement

for the compiler to generate synthetic accessors: functions that
don't appear in the source but do appear in the class file.

Patch by: Douglas Miles <dmiles _at_ users.sf.net>
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 33.9 KB
Line 
1/*
2 * StringFunctions.java
3 *
4 * Copyright (C) 2003-2005 Peter Graves
5 * Copyright (C) 2010 Ville Voutilainen
6 * $Id: StringFunctions.java 12513 2010-03-02 22:35:36Z ehuelsmann $
7 *
8 * This program is free software; you can redistribute it and/or
9 * modify it under the terms of the GNU General Public License
10 * as published by the Free Software Foundation; either version 2
11 * of the License, or (at your option) any later version.
12 *
13 * This program is distributed in the hope that it will be useful,
14 * but WITHOUT ANY WARRANTY; without even the implied warranty of
15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 * GNU General Public License for more details.
17 *
18 * You should have received a copy of the GNU General Public License
19 * along with this program; if not, write to the Free Software
20 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
21 *
22 * As a special exception, the copyright holders of this library give you
23 * permission to link this library with independent modules to produce an
24 * executable, regardless of the license terms of these independent
25 * modules, and to copy and distribute the resulting executable under
26 * terms of your choice, provided that you also meet, for each linked
27 * independent module, the terms and conditions of the license of that
28 * module.  An independent module is a module which is not derived from
29 * or based on this library.  If you modify this library, you may extend
30 * this exception to your version of the library, but you are not
31 * obligated to do so.  If you do not wish to do so, delete this
32 * exception statement from your version.
33 */
34
35package org.armedbear.lisp;
36
37import static org.armedbear.lisp.Lisp.*;
38import java.util.Arrays;
39public final class StringFunctions {
40    final static class StringIndicesAndChars {
41        public AbstractString string1;
42        public boolean convertCase = false;
43        public char[] array1;
44        public char[] array2;
45        public int start1 = 0;
46        public int end1 = 0;
47        public int start2 = 0;
48        public int end2 = 0;
49    };
50    private final static void 
51        checkParams(StringIndicesAndChars indicesAndChars) {
52        if (indicesAndChars.start1 < 0 
53            || indicesAndChars.start1 > indicesAndChars.array1.length)
54            error(new TypeError("Invalid start position " 
55                                + indicesAndChars.start1 + "."));
56        if (indicesAndChars.end1 < 0 
57            || indicesAndChars.end1 > indicesAndChars.array1.length)
58            error(new TypeError("Invalid end position " 
59                                + indicesAndChars.end1 + "."));
60       
61        if (indicesAndChars.start1 > indicesAndChars.end1) 
62            error(new TypeError("Start (" 
63                                + indicesAndChars.start1 
64                                + ") is greater than end (" 
65                                + indicesAndChars.end1 + ")."));
66        if (indicesAndChars.array2 != null) {
67            if (indicesAndChars.start2 < 0 
68                || indicesAndChars.start2 > indicesAndChars.array2.length)
69                error(new TypeError("Invalid start2 position " 
70                                    + indicesAndChars.start2 + "."));
71            if (indicesAndChars.end2 < 0 
72                || indicesAndChars.end2 > indicesAndChars.array2.length)
73                error(new TypeError("Invalid end2 position " 
74                                    + indicesAndChars.end2 + "."));
75            if (indicesAndChars.start2 > indicesAndChars.end2)
76                error(new TypeError("Start2 (" 
77                                    + indicesAndChars.start2 
78                                    + ") is greater than end2 (" 
79                                    + indicesAndChars.end2 + ")."));
80        }
81
82    }
83   
84    private final static char upcaseIfNeeded(char c, boolean convert) {
85        return convert ? LispCharacter.toUpperCase(c) : c;
86    }
87
88    final static StringIndicesAndChars
89        stringIndicesAndChars(LispObject... params) {
90        StringIndicesAndChars retVal = new StringIndicesAndChars();
91        retVal.string1 = checkString(params[0].STRING());
92        retVal.array1 = retVal.string1.getStringChars();
93        retVal.end1 = retVal.array1.length;
94        if (params.length == 3) {
95            if (params[1] != NIL) {
96                retVal.start1 = Fixnum.getValue(params[1]);
97            }
98            if (params[2] != NIL) {
99                retVal.end1 = Fixnum.getValue(params[2]);
100            }
101        } else {
102            retVal.array2 = params[1].STRING().getStringChars();
103            retVal.end2 = retVal.array2.length;
104            if (params.length > 2) {
105                if (params[2] != NIL) {
106                    retVal.start1 = Fixnum.getValue(params[2]);
107                }
108                if (params[3] != NIL) {
109                    retVal.end1 = Fixnum.getValue(params[3]);
110                }
111                if (params[4] != NIL) {
112                    retVal.start2 = Fixnum.getValue(params[4]);
113                }
114                if (params[5] != NIL) {
115                    retVal.end2 = Fixnum.getValue(params[5]);
116                }
117            }
118        }
119        checkParams(retVal);
120        return retVal;
121    }
122
123    // ### %%string=
124    // Case sensitive.
125    private static final Primitive __STRING_EQUAL = new pf___string_equal();
126    private static final class pf___string_equal extends Primitive {
127        pf___string_equal() {
128            super("%%string=", PACKAGE_SYS, false);
129        }
130
131        @Override
132        public LispObject execute(LispObject string1, LispObject string2)
133
134        {
135            StringIndicesAndChars chars = 
136                stringIndicesAndChars(string1, string2);
137            return Arrays.equals(chars.array1, chars.array2) ?
138                T : NIL;
139        };
140    }
141
142    // ### %string=
143    // Case sensitive.
144    private static final Primitive _STRING_EQUAL = new pf__string_equal();
145    private static final class pf__string_equal extends Primitive {
146        pf__string_equal() {
147            super("%string=", PACKAGE_SYS, false);
148        }
149
150        @Override
151        public LispObject execute(LispObject string1, LispObject string2,
152                                  LispObject start1, LispObject end1,
153                                  LispObject start2, LispObject end2)
154
155        {
156            return 
157                (_STRING_NOT_EQUAL.execute(string1, string2, 
158                                           start1, end1, 
159                                           start2, end2)
160                 == NIL) ? T : NIL;
161        }
162    };
163
164
165    static final int notEqual(StringIndicesAndChars indicesAndChars) {
166        int i = indicesAndChars.start1;
167        int j = indicesAndChars.start2;
168        while (true) {
169            if (i == indicesAndChars.end1) {
170                // Reached end of string1.
171                if (j == indicesAndChars.end2)
172                    return -1; // Strings are identical.
173                return i;
174            }
175            if (j == indicesAndChars.end2) {
176                // Reached end of string2 before end of string1.
177                return i;
178            }
179            if (upcaseIfNeeded(indicesAndChars.array1[i],
180                               indicesAndChars.convertCase)
181                != upcaseIfNeeded(indicesAndChars.array2[j],
182                                  indicesAndChars.convertCase))
183                return i;
184            ++i;
185            ++j;
186        }
187    }
188    // ### %string/=
189    // Case sensitive.
190    static final Primitive _STRING_NOT_EQUAL = new pf__string_not_equal();
191    private static final class pf__string_not_equal extends Primitive {
192        pf__string_not_equal() {
193            super("%string/=", PACKAGE_SYS, true);
194        }
195
196        @Override
197        public LispObject execute(LispObject string1, LispObject string2,
198                                  LispObject start1, LispObject end1,
199                                  LispObject start2, LispObject end2) {
200            StringIndicesAndChars indicesAndChars = 
201                stringIndicesAndChars(string1, string2, start1, end1,
202                                      start2, end2);
203            int tmp = notEqual(indicesAndChars);
204            return (tmp >= 0) ? Fixnum.getInstance(tmp) : NIL;
205        }
206    };
207
208    // ### %string-equal
209    // Case insensitive.
210    private static final Primitive _STRING_EQUAL_IGNORE_CASE = new pf__string_equal_ignore_case();
211    private static final class pf__string_equal_ignore_case extends Primitive {
212        pf__string_equal_ignore_case() {
213            super("%string-equal", PACKAGE_SYS, true);
214        }
215
216        @Override
217        public LispObject execute(LispObject string1, LispObject string2,
218                                  LispObject start1, LispObject end1,
219                                  LispObject start2, LispObject end2)
220
221        {
222            return (_STRING_NOT_EQUAL_IGNORE_CASE.execute(string1, string2, 
223                                                          start1, end1, 
224                                                          start2, end2) 
225                    == NIL) ? T : NIL;
226        }
227    };
228
229    // ### %string-not-equal
230    // Case insensitive.
231    static final Primitive _STRING_NOT_EQUAL_IGNORE_CASE = new pf__string_not_equal_ignore_case();
232    private static final class pf__string_not_equal_ignore_case extends Primitive {
233        pf__string_not_equal_ignore_case() {
234            super("%string-not-equal", PACKAGE_SYS, true);
235        }
236
237        @Override
238        public LispObject execute(LispObject string1, LispObject string2,
239                                  LispObject start1, LispObject end1,
240                                  LispObject start2, LispObject end2) {
241            StringIndicesAndChars indicesAndChars = 
242                stringIndicesAndChars(string1, string2, start1, end1,
243                                      start2, end2);
244            indicesAndChars.convertCase = true;
245            int tmp = notEqual(indicesAndChars);
246            return (tmp >= 0) ? Fixnum.getInstance(tmp) : NIL;
247        }
248    };
249
250    static final int lessThan(StringIndicesAndChars indicesAndChars) {
251        int i = indicesAndChars.start1;
252        int j = indicesAndChars.start2;
253        while (true) {
254            if (i == indicesAndChars.end1) {
255                // Reached end of string1.
256                if (j == indicesAndChars.end2)
257                    return -1; // Strings are identical.
258                return i;
259            }
260            if (j == indicesAndChars.end2) {
261                // Reached end of string2.
262                return -1;
263            }
264            char c1 = upcaseIfNeeded(indicesAndChars.array1[i], 
265                                     indicesAndChars.convertCase);
266            char c2 = upcaseIfNeeded(indicesAndChars.array2[j],
267                                     indicesAndChars.convertCase);
268            if (c1 == c2) {
269                ++i;
270                ++j;
271                continue;
272            }
273            if (c1 < c2)
274                return (i);
275            // c1 > c2
276            return -1;
277        }
278    }
279
280    // ### %string<
281    // Case sensitive.
282    private static final Primitive _STRING_LESS_THAN = new pf__string_less_than();
283    private static final class pf__string_less_than extends Primitive {
284        pf__string_less_than() {
285            super("%string<", PACKAGE_SYS, true);
286        }
287
288        @Override
289        public LispObject execute(LispObject string1, LispObject string2,
290                                  LispObject start1, LispObject end1,
291                                  LispObject start2, LispObject end2) {
292            StringIndicesAndChars indicesAndChars = 
293                stringIndicesAndChars(string1, string2, 
294                                      start1, end1, start2, end2);
295            int retVal = lessThan(indicesAndChars);
296            return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL;
297        }
298    };
299
300    static LispObject
301        swapReturnValue(int original,
302                        StringIndicesAndChars indicesAndChars) {
303        if (original < 0) {
304            return NIL;
305        }
306        int delta = original - indicesAndChars.start1;
307        int retVal = indicesAndChars.start2 + delta;
308        return Fixnum.getInstance(retVal);
309    }
310
311    // ### %string>
312    // Case sensitive.
313    private static final Primitive _STRING_GREATER_THAN = new pf__string_greater_than();
314    private static final class pf__string_greater_than extends Primitive {
315        pf__string_greater_than() {
316            super("%string>", PACKAGE_SYS, true);
317        }
318
319        @Override
320        public LispObject execute(LispObject string1, LispObject string2,
321                                  LispObject start1, LispObject end1,
322                                  LispObject start2, LispObject end2) {
323            // note the swap of the strings and lengths here..
324            StringIndicesAndChars indicesAndChars = 
325                stringIndicesAndChars(string2, string1, 
326                                      start2, end2,
327                                      start1, end1);
328            int tmp = lessThan(indicesAndChars);
329            return swapReturnValue(tmp, indicesAndChars);
330        }
331    };
332
333    static final int lessThanOrEqual(StringIndicesAndChars indicesAndChars) {
334        int i = indicesAndChars.start1;
335        int j = indicesAndChars.start2;
336        while (true) {
337            if (i == indicesAndChars.end1) {
338                // Reached end of string1.
339                return i;
340            }
341            if (j == indicesAndChars.end2) {
342                // Reached end of string2.
343                return -1;
344            }
345            char c1 = upcaseIfNeeded(indicesAndChars.array1[i], 
346                                     indicesAndChars.convertCase);
347            char c2 = upcaseIfNeeded(indicesAndChars.array2[j],
348                                     indicesAndChars.convertCase);
349            if (c1 == c2) {
350                ++i;
351                ++j;
352                continue;
353            }
354            if (c1 > c2)
355                return -1;
356            // c1 < c2
357            return (i);
358        }
359    }
360    // ### %string<=
361    // Case sensitive.
362    private static final Primitive _STRING_LE = new pf__string_le();
363    private static final class pf__string_le extends Primitive {
364        pf__string_le() {
365            super("%string<=", PACKAGE_SYS, true);
366        }
367
368        @Override
369        public LispObject execute(LispObject string1, LispObject string2,
370                                  LispObject start1, LispObject end1,
371                                  LispObject start2, LispObject end2) {
372
373            StringIndicesAndChars indicesAndChars = 
374                stringIndicesAndChars(string1, string2, 
375                                      start1, end1, start2, end2);
376            int retVal = lessThanOrEqual(indicesAndChars);
377            return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL;
378        }
379    };
380
381    // ### %string>=
382    // Case sensitive.
383    private static final Primitive _STRING_GE = new pf__string_ge();
384    private static final class pf__string_ge extends Primitive {
385        pf__string_ge() {
386            super("%string>=", PACKAGE_SYS, true);
387        }
388
389        @Override
390        public LispObject execute(LispObject string1, LispObject string2,
391                                  LispObject start1, LispObject end1,
392                                  LispObject start2, LispObject end2) {
393            // note the swap of the strings and lengths here..
394            StringIndicesAndChars indicesAndChars = 
395                stringIndicesAndChars(string2, string1,
396                                      start2, end2,
397                                      start1, end1);
398            int tmp = lessThanOrEqual(indicesAndChars);
399            return swapReturnValue(tmp, indicesAndChars);
400        }
401    };
402
403
404    // ### %string-lessp
405    // Case insensitive.
406    private static final Primitive _STRING_LESSP = new pf__string_lessp();
407    private static final class pf__string_lessp extends Primitive {
408        pf__string_lessp() {
409            super("%string-lessp", PACKAGE_SYS, true);
410        }
411
412        @Override
413        public LispObject execute(LispObject string1, LispObject string2,
414                                  LispObject start1, LispObject end1,
415                                  LispObject start2, LispObject end2) {
416            StringIndicesAndChars indicesAndChars = 
417                stringIndicesAndChars(string1, string2, 
418                                      start1, end1, start2, end2);
419            indicesAndChars.convertCase = true;
420            int retVal = lessThan(indicesAndChars);
421            return (retVal >= 0) ? Fixnum.getInstance(retVal) : NIL;
422        }
423    };
424
425    // ### %string-greaterp
426    // Case insensitive.
427    private static final Primitive _STRING_GREATERP = new pf__string_greaterp();
428    private static final class pf__string_greaterp extends Primitive {
429        pf__string_greaterp() {
430            super("%string-greaterp", PACKAGE_SYS, true);
431        }
432
433        @Override
434        public LispObject execute(LispObject string1, LispObject string2,
435                                  LispObject start1, LispObject end1,
436                                  LispObject start2, LispObject end2) {
437            // note the swap of the strings and lengths here..
438            StringIndicesAndChars indicesAndChars = 
439                stringIndicesAndChars(string2, string1,
440                                      start2, end2,
441                                      start1, end1);
442            indicesAndChars.convertCase = true;
443            int tmp = lessThan(indicesAndChars);
444            return swapReturnValue(tmp, indicesAndChars);
445        }
446    };
447    // ### %string-not-lessp
448    // Case insensitive.
449    private static final Primitive _STRING_NOT_LESSP = new pf__string_not_lessp();
450    private static final class pf__string_not_lessp extends Primitive {
451        pf__string_not_lessp() {
452            super("%string-not-lessp", PACKAGE_SYS, true);
453        }
454
455        @Override
456        public LispObject execute(LispObject string1, LispObject string2,
457                                  LispObject start1, LispObject end1,
458                                  LispObject start2, LispObject end2) {
459            // note the swap of the strings and lengths here..
460            StringIndicesAndChars indicesAndChars = 
461                stringIndicesAndChars(string2, string1,
462                                      start2, end2,
463                                      start1, end1);
464            indicesAndChars.convertCase = true;
465            int tmp = lessThanOrEqual(indicesAndChars);
466            return swapReturnValue(tmp, indicesAndChars);
467        }
468    };
469
470    // ### %string-not-greaterp
471    // Case insensitive.
472    private static final Primitive _STRING_NOT_GREATERP = new pf__string_not_greaterp();
473    private static final class pf__string_not_greaterp extends Primitive {
474        pf__string_not_greaterp() {
475            super("%string-not-greaterp", PACKAGE_SYS, true);
476        }
477
478        @Override
479        public LispObject execute(LispObject string1, LispObject string2,
480                                  LispObject start1, LispObject end1,
481                                  LispObject start2, LispObject end2) {
482            StringIndicesAndChars indicesAndChars = 
483                stringIndicesAndChars(string1, string2,
484                                      start1, end1,
485                                      start2, end2);
486            indicesAndChars.convertCase = true;
487            int tmp = lessThanOrEqual(indicesAndChars);
488            return (tmp >= 0) ? Fixnum.getInstance(tmp) : NIL;
489        }
490    };
491
492    // ### %string-upcase
493    private static final Primitive _STRING_UPCASE = new pf__string_upcase();
494    private static final class pf__string_upcase extends Primitive {
495        pf__string_upcase() {
496            super("%string-upcase", PACKAGE_SYS, true);
497        }
498
499        @Override
500        public LispObject execute(LispObject string, LispObject start,
501                                  LispObject end)
502
503        {
504            StringIndicesAndChars indicesAndChars = 
505                stringIndicesAndChars(string, start, end);
506            char[] array = new char[indicesAndChars.array1.length];
507            System.arraycopy(indicesAndChars.array1, 0,
508                             array, 0,
509                             indicesAndChars.start1);
510            for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++)
511                array[i] = LispCharacter.toUpperCase(indicesAndChars.array1[i]);
512            System.arraycopy(indicesAndChars.array1, indicesAndChars.end1,
513                      array, indicesAndChars.end1,
514                             indicesAndChars.array1.length 
515                             - indicesAndChars.end1);
516            return new SimpleString(array);
517        }
518    };
519
520    // ### %string-downcase
521    private static final Primitive _STRING_DOWNCASE = new pf__string_downcase();
522    private static final class pf__string_downcase extends Primitive {
523        pf__string_downcase() {
524            super("%string-downcase", PACKAGE_SYS, true);
525        }
526
527        @Override
528        public LispObject execute(LispObject string, LispObject start,
529                                  LispObject end) {
530            StringIndicesAndChars indicesAndChars = 
531                stringIndicesAndChars(string, start, end);
532            char[] array = new char[indicesAndChars.array1.length];
533            System.arraycopy(indicesAndChars.array1, 0,
534                             array, 0,
535                             indicesAndChars.start1);
536            for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++)
537                array[i] = LispCharacter.toLowerCase(indicesAndChars.array1[i]);
538            System.arraycopy(indicesAndChars.array1, indicesAndChars.end1,
539                      array, indicesAndChars.end1,
540                             indicesAndChars.array1.length 
541                             - indicesAndChars.end1);
542            return new SimpleString(array);
543        }
544    };
545
546    // ### %string-capitalize
547    private static final Primitive _STRING_CAPITALIZE = new pf__string_capitalize();
548    private static final class pf__string_capitalize extends Primitive {
549        pf__string_capitalize() {
550            super("%string-capitalize", PACKAGE_SYS, true);
551        }
552
553        @Override
554        public LispObject execute(LispObject string, LispObject start,
555                                  LispObject end)
556
557        {
558            StringIndicesAndChars indicesAndChars = 
559                stringIndicesAndChars(string, start, end);
560            char[] array = new char[indicesAndChars.array1.length];
561            boolean lastCharWasAlphanumeric = false;
562            System.arraycopy(indicesAndChars.array1, 0,
563                             array, 0,
564                             indicesAndChars.start1);
565            for (int i = indicesAndChars.start1; 
566                 i < indicesAndChars.end1; i++) {
567                char c = indicesAndChars.array1[i];
568                if (Character.isLowerCase(c)) {
569                    array[i] = lastCharWasAlphanumeric ? 
570                        c : LispCharacter.toUpperCase(c);
571                    lastCharWasAlphanumeric = true;
572                } else if (Character.isUpperCase(c)) {
573                    array[i] = lastCharWasAlphanumeric ? 
574                        LispCharacter.toLowerCase(c) : c;
575                    lastCharWasAlphanumeric = true;
576                } else {
577                    array[i] = c;
578                    lastCharWasAlphanumeric = Character.isDigit(c);
579                }
580            }
581            System.arraycopy(indicesAndChars.array1, indicesAndChars.end1,
582                      array, indicesAndChars.end1,
583                             indicesAndChars.array1.length 
584                             - indicesAndChars.end1);
585            return new SimpleString(array);
586        }
587    };
588
589    // ### %nstring-upcase
590    private static final Primitive _NSTRING_UPCASE = new pf__nstring_upcase();
591    private static final class pf__nstring_upcase extends Primitive {
592        pf__nstring_upcase() {
593            super("%nstring-upcase", PACKAGE_SYS, true);
594        }
595
596        @Override
597        public LispObject execute(LispObject string, LispObject start,
598                                  LispObject end)
599
600        {
601            StringIndicesAndChars indicesAndChars = 
602                stringIndicesAndChars(string, start, end);
603            AbstractString retString = indicesAndChars.string1; 
604            for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++) 
605                retString.setCharAt(i,
606                                    LispCharacter.
607                                    toUpperCase(
608                                                retString.charAt(i)));
609            return retString;
610        }
611    };
612
613    // ### %nstring-downcase
614    private static final Primitive _NSTRING_DOWNCASE = new pf__nstring_downcase();
615    private static final class pf__nstring_downcase extends Primitive {
616        pf__nstring_downcase() {
617            super("%nstring-downcase", PACKAGE_SYS, true);
618        }
619
620        @Override
621        public LispObject execute(LispObject string, LispObject start,
622                                  LispObject end)
623
624        {
625            StringIndicesAndChars indicesAndChars = 
626                stringIndicesAndChars(string, start, end);
627            AbstractString retString = indicesAndChars.string1; 
628            for (int i = indicesAndChars.start1; i < indicesAndChars.end1; i++)
629                retString.setCharAt(i,
630                                    LispCharacter.
631                                    toLowerCase(retString.charAt(i)));
632            return retString;
633        }
634    };
635
636    // ### %nstring-capitalize
637    private static final Primitive _NSTRING_CAPITALIZE = new pf__nstring_capitalize();
638    private static final class pf__nstring_capitalize extends Primitive {
639        pf__nstring_capitalize() {
640            super("%nstring-capitalize", PACKAGE_SYS, true);
641        }
642
643        @Override
644        public LispObject execute(LispObject string, LispObject start,
645                                  LispObject end)
646
647        {
648            StringIndicesAndChars indicesAndChars = 
649                stringIndicesAndChars(string, start, end);
650            boolean lastCharWasAlphanumeric = false;
651            AbstractString retString = indicesAndChars.string1; 
652            for (int i = indicesAndChars.start1; 
653                 i < indicesAndChars.end1; i++) {
654                char c = retString.charAt(i);
655                if (Character.isLowerCase(c)) {
656                    if (!lastCharWasAlphanumeric)
657                        retString.setCharAt(i,
658                                            LispCharacter.toUpperCase(c));
659                    lastCharWasAlphanumeric = true;
660                } else if (Character.isUpperCase(c)) {
661                    if (lastCharWasAlphanumeric)
662                        retString.setCharAt(i,
663                                            LispCharacter.toLowerCase(c));
664                    lastCharWasAlphanumeric = true;
665                } else
666                    lastCharWasAlphanumeric = Character.isDigit(c);
667            }
668            return retString;
669        }
670    };
671
672    // ### stringp
673    public static final Primitive STRINGP = new pf_stringp();
674    private static final class pf_stringp extends Primitive {
675        pf_stringp() {
676            super("stringp", "object");
677        }
678
679        @Override
680        public LispObject execute(LispObject arg) {
681            return arg.STRINGP();
682        }
683    };
684
685    // ### simple-string-p
686    public static final Primitive SIMPLE_STRING_P = new pf_simple_string_p();
687    private static final class pf_simple_string_p extends Primitive {
688        pf_simple_string_p() {
689            super("simple-string-p", "object");
690        }
691
692        @Override
693        public LispObject execute(LispObject arg) {
694            return arg.SIMPLE_STRING_P();
695        }
696    };
697
698    // ### %make-string
699    // %make-string size initial-element element-type => string
700    // Returns a simple string.
701    private static final Primitive _MAKE_STRING = new pf__make_string();
702    private static final class pf__make_string extends Primitive {
703        pf__make_string() {
704            super("%make-string", PACKAGE_SYS, false);
705        }
706
707        @Override
708        public LispObject execute(LispObject size, LispObject initialElement,
709                                  LispObject elementType)
710
711        {
712            final int n = Fixnum.getValue(size);
713            if (n < 0 || n >= ARRAY_DIMENSION_MAX) {
714                StringBuilder sb = new StringBuilder();
715                sb.append("The size specified for this string (");
716                sb.append(n);
717                sb.append(')');
718                if (n >= ARRAY_DIMENSION_MAX) {
719                    sb.append(" is >= ARRAY-DIMENSION-LIMIT (");
720                    sb.append(ARRAY_DIMENSION_MAX);
721                    sb.append(").");
722                } else
723                    sb.append(" is negative.");
724                return error(new LispError(sb.toString()));
725            }
726            // Ignore elementType.
727            SimpleString string = new SimpleString(n);
728            if (initialElement != NIL) {
729                // Initial element was specified.
730                char c = checkCharacter(initialElement).getValue();
731                string.fill(c);
732            }
733            return string;
734        }
735    };
736
737    // ### char
738    private static final Primitive CHAR = new pf_char();
739    private static final class pf_char extends Primitive {
740        pf_char() {
741            super(Symbol.CHAR, "string index");
742        }
743
744        @Override
745        public LispObject execute(LispObject first, LispObject second)
746
747        {
748            return first.CHAR(Fixnum.getValue(second));
749        }
750    };
751
752    // ### schar
753    private static final Primitive SCHAR = new pf_schar();
754    private static final class pf_schar extends Primitive {
755        pf_schar() {
756            super(Symbol.SCHAR, "string index");
757        }
758
759        @Override
760        public LispObject execute(LispObject first, LispObject second)
761
762        {
763            return first.SCHAR(Fixnum.getValue(second));
764        }
765    };
766
767    // ### set-char
768    private static final Primitive SET_CHAR = new pf_set_char();
769    private static final class pf_set_char extends Primitive {
770        pf_set_char() {
771            super(Symbol.SET_CHAR, "string index character");
772        }
773
774        @Override
775        public LispObject execute(LispObject first, LispObject second,
776                                  LispObject third)
777
778        {
779            checkString(first).setCharAt(Fixnum.getValue(second),
780                                         LispCharacter.getValue(third));
781            return third;
782        }
783    };
784
785    // ### set-schar
786    private static final Primitive SET_SCHAR = new pf_set_schar();
787    private static final class pf_set_schar extends Primitive {
788        pf_set_schar() {
789            super(Symbol.SET_SCHAR, "string index character");
790        }
791
792        @Override
793        public LispObject execute(LispObject first, LispObject second,
794                                  LispObject third)
795
796        {
797            if (first instanceof SimpleString) {
798                ((SimpleString)first).setCharAt(Fixnum.getValue(second),
799                                                LispCharacter.getValue(third));
800                return third;
801            }
802            return type_error(first, Symbol.SIMPLE_STRING);
803        }
804    };
805
806    // ### string-position
807    private static final Primitive STRING_POSITION = new pf_string_position();
808    private static final class pf_string_position extends Primitive {
809        pf_string_position() {
810            super("string-position", PACKAGE_EXT, true);
811        }
812
813        @Override
814        public LispObject execute(LispObject first, LispObject second,
815                                  LispObject third)
816
817        {
818            char c = LispCharacter.getValue(first);
819            AbstractString string = checkString(second);
820            int start = Fixnum.getValue(third);
821            for (int i = start, limit = string.length(); i < limit; i++) {
822                if (string.charAt(i) == c)
823                    return number(i);
824            }
825            return NIL;
826        }
827    };
828
829    // ### string-find
830    private static final Primitive STRING_FIND = new pf_string_find();
831    private static final class pf_string_find extends Primitive {
832        pf_string_find() {
833            super("string-find", PACKAGE_EXT, true, "char string");
834        }
835
836        @Override
837        public LispObject execute(LispObject first, LispObject second)
838
839        {
840            if (first instanceof LispCharacter) {
841                final char c = ((LispCharacter)first).value;
842                AbstractString string = Lisp.checkString(second);
843                final int limit = string.length();
844                for (int i = 0; i < limit; i++) {
845                    if (string.charAt(i) == c)
846                        return first;
847                }
848            }
849            return NIL;
850        }
851    };
852
853    // ### simple-string-search pattern string => position
854    // Searches string for a substring that matches pattern.
855    private static final Primitive SIMPLE_STRING_SEARCH = new pf_simple_string_search();
856    private static final class pf_simple_string_search extends Primitive {
857        pf_simple_string_search() {
858            super("simple-string-search", PACKAGE_EXT, true);
859        }
860
861        @Override
862        public LispObject execute(LispObject first, LispObject second)
863
864        {
865            // FIXME Don't call getStringValue() here! (Just look at the chars.)
866            int index = second.getStringValue().indexOf(first.getStringValue());
867            return index >= 0 ? Fixnum.getInstance(index) : NIL;
868        }
869    };
870
871    // ### simple-string-fill string character => string
872    private static final Primitive STRING_FILL = new pf_string_fill();
873    private static final class pf_string_fill extends Primitive {
874        pf_string_fill() {
875            super("simple-string-fill", PACKAGE_EXT, true);
876        }
877
878        @Override
879        public LispObject execute(LispObject first, LispObject second)
880
881        {
882            if (first instanceof AbstractString) {
883                AbstractString s = (AbstractString) first;
884                s.fill(LispCharacter.getValue(second));
885                return first;
886            }
887            return type_error(first, Symbol.SIMPLE_STRING);
888        }
889    };
890
891}
Note: See TracBrowser for help on using the repository browser.