source: branches/0.15.x/abcl/src/org/armedbear/lisp/LispCharacter.java

Last change on this file was 11836, checked in by ehuelsmann, 16 years ago

Support the #\Escape character.

Patch by: Eric Marsden (eric marsden free fr)
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 16.6 KB
Line 
1/*
2 * LispCharacter.java
3 *
4 * Copyright (C) 2002-2007 Peter Graves
5 * $Id: LispCharacter.java 11836 2009-05-06 18:52:17Z ehuelsmann $
6 *
7 * This program is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20 *
21 * As a special exception, the copyright holders of this library give you
22 * permission to link this library with independent modules to produce an
23 * executable, regardless of the license terms of these independent
24 * modules, and to copy and distribute the resulting executable under
25 * terms of your choice, provided that you also meet, for each linked
26 * independent module, the terms and conditions of the license of that
27 * module.  An independent module is a module which is not derived from
28 * or based on this library.  If you modify this library, you may extend
29 * this exception to your version of the library, but you are not
30 * obligated to do so.  If you do not wish to do so, delete this
31 * exception statement from your version.
32 */
33
34package org.armedbear.lisp;
35
36public final class LispCharacter extends LispObject
37{
38  public static final LispCharacter[] constants = new LispCharacter[CHAR_MAX];
39
40  static
41  {
42    for (int i = constants.length; i-- > 0;)
43      constants[i] = new LispCharacter((char)i);
44  }
45
46  public final char value;
47
48  public static LispCharacter getInstance(char c)
49  {
50    try
51      {
52        return constants[c];
53      }
54    catch (ArrayIndexOutOfBoundsException e)
55      {
56        return new LispCharacter(c);
57      }
58  }
59
60  // This needs to be public for the compiler.
61  public LispCharacter(char c)
62  {
63    this.value = c;
64  }
65
66  @Override
67  public LispObject typeOf()
68  {
69    if (isStandardChar())
70      return Symbol.STANDARD_CHAR;
71    return Symbol.CHARACTER;
72  }
73
74  @Override
75  public LispObject classOf()
76  {
77    return BuiltInClass.CHARACTER;
78  }
79
80  @Override
81  public LispObject getDescription()
82  {
83    FastStringBuffer sb = new FastStringBuffer("character #\\");
84    sb.append(value);
85    sb.append(" char-code #x");
86    sb.append(Integer.toHexString(value));
87    return new SimpleString(sb);
88  }
89
90  @Override
91  public LispObject typep(LispObject type) throws ConditionThrowable
92  {
93    if (type == Symbol.CHARACTER)
94      return T;
95    if (type == BuiltInClass.CHARACTER)
96      return T;
97    if (type == Symbol.BASE_CHAR)
98      return T;
99    if (type == Symbol.STANDARD_CHAR)
100      return isStandardChar() ? T : NIL;
101    return super.typep(type);
102  }
103
104  @Override
105  public LispObject CHARACTERP()
106  {
107    return T;
108  }
109
110  @Override
111  public boolean characterp()
112  {
113    return true;
114  }
115
116  @Override
117  public LispObject STRING()
118  {
119    return new SimpleString(value);
120  }
121
122  private boolean isStandardChar()
123  {
124    if (value >= ' ' && value < 127)
125      return true;
126    if (value == '\n')
127      return true;
128    return false;
129  }
130
131  @Override
132  public boolean eql(char c)
133  {
134    return value == c;
135  }
136
137  @Override
138  public boolean eql(LispObject obj)
139  {
140    if (this == obj)
141      return true;
142    if (obj instanceof LispCharacter)
143      {
144        if (value == ((LispCharacter)obj).value)
145          return true;
146      }
147    return false;
148  }
149
150  @Override
151  public boolean equal(LispObject obj)
152  {
153    if (this == obj)
154      return true;
155    if (obj instanceof LispCharacter)
156      {
157        if (value == ((LispCharacter)obj).value)
158          return true;
159      }
160    return false;
161  }
162
163  @Override
164  public boolean equalp(LispObject obj)
165  {
166    if (this == obj)
167      return true;
168    if (obj instanceof LispCharacter)
169      {
170        if (value == ((LispCharacter)obj).value)
171          return true;
172        return LispCharacter.toLowerCase(value) == LispCharacter.toLowerCase(((LispCharacter)obj).value);
173      }
174    return false;
175  }
176
177  public static char getValue(LispObject obj) throws ConditionThrowable
178  {       
179          if (obj instanceof LispCharacter)
180        return ((LispCharacter)obj).value;
181      type_error(obj, Symbol.CHARACTER);
182        // Not reached.
183      return 0;
184  }
185
186  public final char getValue()
187  {
188    return value;
189  }
190
191  @Override
192  public Object javaInstance()
193  {
194    return Character.valueOf(value);
195  }
196
197  @Override
198  public Object javaInstance(Class c)
199  {
200    return javaInstance();
201  }
202
203  @Override
204  public int sxhash()
205  {
206    return value;
207  }
208
209  @Override
210  public int psxhash()
211  {
212    return Character.toUpperCase(value);
213  }
214
215  @Override
216  public final String writeToString() throws ConditionThrowable
217  {
218    final LispThread thread = LispThread.currentThread();
219    boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL);
220    // "Specifically, if *PRINT-READABLY* is true, printing proceeds as if
221    // *PRINT-ESCAPE*, *PRINT-ARRAY*, and *PRINT-GENSYM* were also true,
222    // and as if *PRINT-LENGTH*, *PRINT-LEVEL*, and *PRINT-LINES* were
223    // false."
224    boolean printEscape =
225      printReadably || (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL);
226    FastStringBuffer sb = new FastStringBuffer();
227    if (printEscape)
228      {
229        sb.append("#\\");
230        switch (value)
231          {
232          case 0:
233            sb.append("Null");
234            break;
235          case 7:
236            sb.append("Bell");
237            break;
238          case '\b':
239            sb.append("Backspace");
240            break;
241          case '\t':
242            sb.append("Tab");
243            break;
244          case '\n':
245            sb.append("Newline");
246            break;
247          case '\f':
248            sb.append("Page");
249            break;
250          case '\r':
251            sb.append("Return");
252            break;
253          case 27:
254            sb.append("Escape");
255            break;
256          case 127:
257            sb.append("Rubout");
258            break;
259          default:
260            sb.append(value);
261            break;
262          }
263      }
264    else
265      {
266        sb.append(value);
267      }
268    return sb.toString();
269  }
270
271  // ### character
272  private static final Primitive CHARACTER =
273    new Primitive(Symbol.CHARACTER, "character")
274    {
275      @Override
276      public LispObject execute(LispObject arg) throws ConditionThrowable
277      {
278        if (arg instanceof LispCharacter)
279          return arg;
280        if (arg instanceof AbstractString)
281          {
282            if (arg.length() == 1)
283              return ((AbstractString)arg).AREF(0);
284          }
285        else if (arg instanceof Symbol)
286          {
287            String name = ((Symbol)arg).getName();
288            if (name.length() == 1)
289              return LispCharacter.getInstance(name.charAt(0));
290          }
291        return type_error(arg, Symbol.CHARACTER_DESIGNATOR);
292      }
293    };
294
295  // ### whitespacep
296  private static final Primitive WHITESPACEP =
297    new Primitive("whitespacep", PACKAGE_SYS, true)
298    {
299      @Override
300      public LispObject execute(LispObject arg) throws ConditionThrowable
301      {
302          return Character.isWhitespace(LispCharacter.getValue(arg)) ? T : NIL;
303      }
304    };
305
306  // ### char-code
307  private static final Primitive CHAR_CODE =
308    new Primitive(Symbol.CHAR_CODE, "character")
309    {
310      @Override
311      public LispObject execute(LispObject arg) throws ConditionThrowable
312      {
313          int n = LispCharacter.getValue(arg);
314          return Fixnum.getInstance(n);
315      }
316    };
317
318  // ### char-int
319  private static final Primitive CHAR_INT =
320    new Primitive(Symbol.CHAR_INT, "character")
321    {
322      @Override
323      public LispObject execute(LispObject arg) throws ConditionThrowable
324      {
325          int n = LispCharacter.getValue(arg);
326          return Fixnum.getInstance(n);
327      }
328    };
329
330  // ### code-char
331  private static final Primitive CODE_CHAR =
332    new Primitive(Symbol.CODE_CHAR, "code")
333    {
334      @Override
335      public LispObject execute(LispObject arg) throws ConditionThrowable
336      {
337          int n = Fixnum.getValue(arg);
338          if (n < CHAR_MAX)
339            return constants[n];
340          else if (n <= Character.MAX_VALUE)
341            return new LispCharacter((char)n);
342              // SBCL signals a type-error here: "not of type (UNSIGNED-BYTE 8)"
343        return NIL;
344      }
345    };
346
347  // ### characterp
348  private static final Primitive CHARACTERP =
349    new Primitive(Symbol.CHARACTERP, "object")
350    {
351      @Override
352      public LispObject execute(LispObject arg) throws ConditionThrowable
353      {
354        return arg instanceof LispCharacter ? T : NIL;
355      }
356    };
357
358  // ### both-case-p
359  private static final Primitive BOTH_CASE_P =
360    new Primitive(Symbol.BOTH_CASE_P, "character")
361    {
362      @Override
363      public LispObject execute(LispObject arg) throws ConditionThrowable
364      {
365        char c = getValue(arg);
366        if (Character.isLowerCase(c) || Character.isUpperCase(c))
367          return T;
368        return NIL;
369      }
370    };
371
372  // ### lower-case-p
373  private static final Primitive LOWER_CASE_P =
374    new Primitive(Symbol.LOWER_CASE_P, "character")
375    {
376      @Override
377      public LispObject execute(LispObject arg) throws ConditionThrowable
378      {
379        return Character.isLowerCase(getValue(arg)) ? T : NIL;
380      }
381    };
382
383  // ### upper-case-p
384  private static final Primitive UPPER_CASE_P =
385    new Primitive(Symbol.UPPER_CASE_P, "character")
386    {
387      @Override
388      public LispObject execute(LispObject arg) throws ConditionThrowable
389      {
390        return Character.isUpperCase(getValue(arg)) ? T : NIL;
391      }
392    };
393
394  // ### char-downcase
395  private static final Primitive CHAR_DOWNCASE =
396    new Primitive(Symbol.CHAR_DOWNCASE, "character")
397    {
398      @Override
399      public LispObject execute(LispObject arg) throws ConditionThrowable
400      {
401          final char c = LispCharacter.getValue(arg);
402          if (c < 128)
403           return constants[LOWER_CASE_CHARS[c]];
404        return LispCharacter.getInstance(toLowerCase(c));
405      }
406    };
407
408  // ### char-upcase
409  private static final Primitive CHAR_UPCASE =
410    new Primitive(Symbol.CHAR_UPCASE, "character")
411    {
412      @Override
413      public LispObject execute(LispObject arg) throws ConditionThrowable
414      {
415        final char c;
416        c = LispCharacter.getValue(arg);
417        if (c < 128)
418          return constants[UPPER_CASE_CHARS[c]];
419        return LispCharacter.getInstance(toUpperCase(c));
420      }
421    };
422
423  // ### digit-char
424  private static final Primitive DIGIT_CHAR =
425    new Primitive(Symbol.DIGIT_CHAR, "weight &optional radix")
426    {
427      @Override
428      public LispObject execute(LispObject arg) throws ConditionThrowable
429      {
430          if (arg instanceof Bignum)
431              return NIL;
432
433          int weight = Fixnum.getValue(arg);
434        if (weight < 10)
435          return constants['0'+weight];
436        return NIL;
437      }
438      @Override
439      public LispObject execute(LispObject first, LispObject second)
440        throws ConditionThrowable
441      {
442        int radix;
443        if (second instanceof Fixnum)
444            radix = ((Fixnum)second).value;
445        else
446            radix = -1;
447       
448        if (radix < 2 || radix > 36)
449          return type_error(second,
450                                 list(Symbol.INTEGER, Fixnum.TWO,
451                                       Fixnum.constants[36]));
452        if (first instanceof Bignum)
453            return NIL;
454        int weight = Fixnum.getValue(first);
455        if (weight >= radix)
456          return NIL;
457        if (weight < 10)
458          return constants['0' + weight];
459        return constants['A' + weight - 10];
460      }
461    };
462
463  // ### digit-char-p char &optional radix => weight
464  private static final Primitive DIGIT_CHAR_P =
465    new Primitive(Symbol.DIGIT_CHAR_P, "char &optional radix")
466    {
467      @Override
468      public LispObject execute(LispObject arg) throws ConditionThrowable
469      {
470          final int n = Character.digit(LispCharacter.getValue(arg), 10);
471          return n < 0 ? NIL : Fixnum.getInstance(n);
472      }
473      @Override
474      public LispObject execute(LispObject first, LispObject second)
475        throws ConditionThrowable
476      {
477        char c;
478            c = LispCharacter.getValue(first);
479        if (second instanceof Fixnum)
480          {
481            int radix = ((Fixnum)second).value;
482            if (radix >= 2 && radix <= 36)
483              {
484                int n = Character.digit(c, radix);
485                return n < 0 ? NIL : Fixnum.constants[n];
486              }
487          }
488        return type_error(second,
489                               list(Symbol.INTEGER, Fixnum.TWO,
490                                     Fixnum.constants[36]));
491      }
492    };
493
494  // ### standard-char-p
495  private static final Primitive STANDARD_CHAR_P =
496    new Primitive(Symbol.STANDARD_CHAR_P, "character")
497    {
498      @Override
499      public LispObject execute(LispObject arg) throws ConditionThrowable
500      {
501          return checkCharacter(arg).isStandardChar() ? T : NIL;
502      }
503    };
504
505  // ### graphic-char-p
506  private static final Primitive GRAPHIC_CHAR_P =
507    new Primitive(Symbol.GRAPHIC_CHAR_P, "char")
508    {
509      @Override
510      public LispObject execute(LispObject arg) throws ConditionThrowable
511      {
512          char c = LispCharacter.getValue(arg);
513          if (c >= ' ' && c < 127)
514            return T;
515          return Character.isISOControl(c) ? NIL : T;
516      }
517    };
518
519  // ### alpha-char-p
520  private static final Primitive ALPHA_CHAR_P =
521    new Primitive(Symbol.ALPHA_CHAR_P, "character")
522    {
523      @Override
524      public LispObject execute(LispObject arg) throws ConditionThrowable
525      {
526          return Character.isLetter(LispCharacter.getValue(arg)) ? T : NIL;
527      }
528    };
529
530  // ### alphanumericp
531  private static final Primitive ALPHANUMERICP =
532    new Primitive(Symbol.ALPHANUMERICP, "character")
533    {
534      @Override
535      public LispObject execute(LispObject arg) throws ConditionThrowable
536      {
537          return Character.isLetterOrDigit(LispCharacter.getValue(arg)) ? T : NIL;
538      }
539    };
540
541  public static final int nameToChar(String s)
542  {
543    String lower = s.toLowerCase();
544    if (lower.equals("null"))
545      return 0;
546    if (lower.equals("bell"))
547      return 7;
548    if (lower.equals("backspace"))
549      return '\b';
550    if (lower.equals("tab"))
551      return '\t';
552    if (lower.equals("linefeed"))
553      return '\n';
554    if (lower.equals("newline"))
555      return '\n';
556    if (lower.equals("page"))
557      return '\f';
558    if (lower.equals("return"))
559      return '\r';
560    if (lower.equals("escape"))
561        return 27;
562    if (lower.equals("space"))
563      return ' ';
564    if (lower.equals("rubout"))
565      return 127;
566    // Unknown.
567    return -1;
568  }
569
570  // ### name-char
571  private static final Primitive NAME_CHAR =
572    new Primitive(Symbol.NAME_CHAR, "name")
573    {
574      @Override
575      public LispObject execute(LispObject arg) throws ConditionThrowable
576      {
577        String s = arg.STRING().getStringValue();
578        int n = nameToChar(s);
579        return n >= 0 ? LispCharacter.getInstance((char)n) : NIL;
580      }
581    };
582
583  public static final String charToName(char c)
584  {
585    switch (c)
586      {
587      case 0:
588        return "Null";
589      case 7:
590        return "Bell";
591      case '\b':
592        return "Backspace";
593      case '\t':
594        return "Tab";
595      case '\n':
596        return "Newline";
597      case '\f':
598        return "Page";
599      case '\r':
600        return "Return";
601      case 27:
602        return "Escape";
603      case ' ':
604        return "Space";
605      case 127:
606        return "Rubout";
607      }
608    return null;
609  }
610
611  // ### char-name
612  private static final Primitive CHAR_NAME =
613    new Primitive(Symbol.CHAR_NAME, "character")
614    {
615      @Override
616      public LispObject execute(LispObject arg) throws ConditionThrowable
617      {
618        String name = charToName(LispCharacter.getValue(arg));
619        return name != null ? new SimpleString(name) : NIL;
620      }
621    };
622
623  public static final char toUpperCase(char c)
624  {
625    if (c < 128)
626      return UPPER_CASE_CHARS[c];
627    return Character.toUpperCase(c);
628  }
629
630  private static final char[] UPPER_CASE_CHARS = new char[128];
631
632  static
633  {
634    for (int i = UPPER_CASE_CHARS.length; i-- > 0;)
635      UPPER_CASE_CHARS[i] = Character.toUpperCase((char)i);
636  }
637
638  public static final char toLowerCase(char c)
639  {
640    if (c < 128)
641      return LOWER_CASE_CHARS[c];
642    return Character.toLowerCase(c);
643  }
644
645  private static final char[] LOWER_CASE_CHARS = new char[128];
646
647  static
648  {
649    for (int i = LOWER_CASE_CHARS.length; i-- > 0;)
650      LOWER_CASE_CHARS[i] = Character.toLowerCase((char)i);
651  }
652}
Note: See TracBrowser for help on using the repository browser.