LispCharacter


1   /*
2    * LispCharacter.java
3    *
4    * Copyright (C) 2002-2004 Peter Graves
5    * $Id: LispCharacter.java,v 1.54 2004/09/08 18:10:58 piso Exp $
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  
22  package org.armedbear.lisp;
23  
24  public final class LispCharacter extends LispObject
25  {
26      private static final LispCharacter[] characters = new LispCharacter[CHAR_MAX];
27  
28      static {
29          for (int i = characters.length; i-- > 0;)
30              characters[i] = new LispCharacter((char)i);
31      }
32  
33      public final char value;
34  
35      public static LispCharacter getInstance(char c)
36      {
37          try {
38              return characters[c];
39          }
40          catch (ArrayIndexOutOfBoundsException   e) {
41              return new LispCharacter(c);
42          }
43      }
44  
45      private LispCharacter(char c)
46      {
47          this.value = c;
48      }
49  
50      public LispObject typeOf()
51      {
52          return Symbol.CHARACTER;
53      }
54  
55      public LispClass classOf()
56      {
57          return BuiltInClass.CHARACTER;
58      }
59  
60      public LispObject getDescription()
61      {
62          StringBuffer   sb = new StringBuffer  ("character #\\");
63          sb.append(value);
64          sb.append(" char-code #x");
65          sb.append(Integer.toHexString(value));
66          return new SimpleString(sb);
67      }
68  
69      public LispObject typep(LispObject type) throws ConditionThrowable
70      {
71          if (type == Symbol.CHARACTER)
72              return T;
73          if (type == BuiltInClass.CHARACTER)
74              return T;
75          if (type == Symbol.BASE_CHAR)
76              return T;
77          if (type == Symbol.STANDARD_CHAR)
78              return isStandardChar();
79          return super.typep(type);
80      }
81  
82      public LispObject CHARACTERP()
83      {
84          return T;
85      }
86  
87      public boolean characterp()
88      {
89          return true;
90      }
91  
92      public LispObject STRING()
93      {
94          return new SimpleString(value);
95      }
96  
97      public LispObject isStandardChar()
98      {
99          if (value >= ' ' && value < 127)
100             return T;
101         if (value == '\n')
102             return T;
103         return NIL;
104     }
105 
106     public boolean eql(LispObject obj)
107     {
108         if (this == obj)
109             return true;
110         if (obj instanceof LispCharacter) {
111             if (value == ((LispCharacter)obj).value)
112                 return true;
113         }
114         return false;
115     }
116 
117     public boolean equal(LispObject obj)
118     {
119         if (this == obj)
120             return true;
121         if (obj instanceof LispCharacter) {
122             if (value == ((LispCharacter)obj).value)
123                 return true;
124         }
125         return false;
126     }
127 
128     public boolean equalp(LispObject obj)
129     {
130         if (this == obj)
131             return true;
132         if (obj instanceof LispCharacter) {
133             if (value == ((LispCharacter)obj).value)
134                 return true;
135             return Utilities.toLowerCase(value) == Utilities.toLowerCase(((LispCharacter)obj).value);
136         }
137         return false;
138     }
139 
140     public static char getValue(LispObject obj) throws ConditionThrowable
141     {
142         try {
143             return ((LispCharacter)obj).getValue();
144         }
145         catch (ClassCastException   e) {
146             signal(new TypeError(obj, "character"));
147             // Not reached.
148             return 0;
149         }
150     }
151 
152     public final char getValue()
153     {
154         return value;
155     }
156 
157     public Object   javaInstance()
158     {
159         return new Character  (value);
160     }
161 
162     public Object   javaInstance(Class   c)
163     {
164         return javaInstance();
165     }
166 
167     public int sxhash()
168     {
169         return value;
170     }
171 
172     public int psxhash()
173     {
174         return Character.toUpperCase(value);
175     }
176 
177     public final String   writeToString() throws ConditionThrowable
178     {
179         boolean printReadably = (_PRINT_READABLY_.symbolValue() != NIL);
180         // "Specifically, if *PRINT-READABLY* is true, printing proceeds as if
181         // *PRINT-ESCAPE*, *PRINT-ARRAY*, and *PRINT-GENSYM* were also true,
182         // and as if *PRINT-LENGTH*, *PRINT-LEVEL*, and *PRINT-LINES* were
183         // false."
184         boolean printEscape =
185             printReadably || (_PRINT_ESCAPE_.symbolValue() != NIL);
186         StringBuffer   sb = new StringBuffer  ();
187         if (printEscape) {
188             sb.append("#\\");
189             switch (value) {
190                 case 0:
191                     sb.append("Null");
192                     break;
193                 case '\b':
194                     sb.append("Backspace");
195                     break;
196                 case '\t':
197                     sb.append("Tab");
198                     break;
199                 case '\n':
200                     sb.append("Newline");
201                     break;
202                 case '\f':
203                     sb.append("Page");
204                     break;
205                 case '\r':
206                     sb.append("Return");
207                     break;
208                 case 127:
209                     sb.append("Rubout");
210                     break;
211                 default:
212                     sb.append(value);
213                     break;
214             }
215         } else {
216             sb.append(value);
217         }
218         return sb.toString();
219     }
220 
221     private static final Primitive1 CHARACTER =
222         new Primitive1("character", "character")
223     {
224         public LispObject execute(LispObject arg) throws ConditionThrowable
225         {
226             if (arg instanceof LispCharacter)
227                 return arg;
228             if (arg instanceof AbstractString) {
229                 if (arg.length() == 1)
230                     return ((AbstractString)arg).getRowMajor(0);
231             } else if (arg instanceof Symbol) {
232                 String   name = arg.getName();
233                 if (name.length() == 1)
234                     return getInstance(name.charAt(0));
235             }
236             return signal(new TypeError());
237         }
238     };
239 
240     // ### whitespacep
241     private static final Primitive1 WHITESPACEP =
242         new Primitive1("whitespacep", PACKAGE_SYS, false)
243     {
244         public LispObject execute(LispObject arg) throws ConditionThrowable
245         {
246             try {
247                 return Character.isWhitespace(((LispCharacter)arg).value) ? T : NIL;
248             }
249             catch (ClassCastException   e) {
250                 return signal(new TypeError(arg, Symbol.CHARACTER));
251             }
252         }
253     };
254 
255     // ### char-code
256     private static final Primitive1 CHAR_CODE = new Primitive1("char-code", "character")
257     {
258         public LispObject execute(LispObject arg) throws ConditionThrowable
259         {
260             try {
261                 return new Fixnum(((LispCharacter)arg).value);
262             }
263             catch (ClassCastException   e) {
264                 return signal(new TypeError(arg, Symbol.CHARACTER));
265             }
266         }
267     };
268 
269     // ### char-int
270     private static final Primitive1 CHAR_INT = new Primitive1("char-int", "character")
271     {
272         public LispObject execute(LispObject arg) throws ConditionThrowable
273         {
274             try {
275                 return new Fixnum(((LispCharacter)arg).value);
276             }
277             catch (ClassCastException   e) {
278                 return signal(new TypeError(arg, Symbol.CHARACTER));
279             }
280         }
281     };
282 
283     // ### code-char
284     private static final Primitive1 CODE_CHAR = new Primitive1("code-char", "code")
285     {
286         public LispObject execute(LispObject arg) throws ConditionThrowable
287         {
288             try {
289                 int n = ((Fixnum)arg).value;
290                 if (n < CHAR_MAX)
291                     return characters[n];
292             }
293             catch (ClassCastException   e) {
294                 ; // SBCL signals a type error here: "not of type (UNSIGNED-BYTE 8)".
295             }
296             return NIL;
297         }
298     };
299 
300     // ### characterp
301     private static final Primitive1 CHARACTERP =
302         new Primitive1("characterp", "object")
303     {
304         public LispObject execute(LispObject arg) throws ConditionThrowable
305         {
306             return arg instanceof LispCharacter ? T : NIL;
307         }
308     };
309 
310     // ### both-case-p
311     private static final Primitive1 BOTH_CASE_P =
312         new Primitive1("both-case-p", "character")
313     {
314         public LispObject execute(LispObject arg) throws ConditionThrowable
315         {
316             char c = getValue(arg);
317             if (Character.isLowerCase(c) || Character.isUpperCase(c))
318                 return T;
319             return NIL;
320         }
321     };
322 
323     // ### lower-case-p
324     private static final Primitive1 LOWER_CASE_P =
325         new Primitive1("lower-case-p", "character")
326     {
327         public LispObject execute(LispObject arg) throws ConditionThrowable
328         {
329             return Character.isLowerCase(getValue(arg)) ? T : NIL;
330         }
331     };
332 
333     // ### upper-case-p
334     private static final Primitive1 UPPER_CASE_P =
335         new Primitive1("upper-case-p", "character")
336     {
337         public LispObject execute(LispObject arg) throws ConditionThrowable
338         {
339             return Character.isUpperCase(getValue(arg)) ? T : NIL;
340         }
341     };
342 
343     // ### char-downcase
344     private static final Primitive1 CHAR_DOWNCASE =
345         new Primitive1("char-downcase", "character")
346     {
347         public LispObject execute(LispObject arg) throws ConditionThrowable
348         {
349             return getInstance(Utilities.toLowerCase(getValue(arg)));
350         }
351     };
352 
353     // ### char-upcase
354     private static final Primitive1 CHAR_UPCASE =
355         new Primitive1("char-upcase", "character")
356     {
357         public LispObject execute(LispObject arg) throws ConditionThrowable
358         {
359             return getInstance(Utilities.toUpperCase(getValue(arg)));
360         }
361     };
362 
363     // ### digit-char
364     private static final Primitive DIGIT_CHAR =
365         new Primitive("digit-char", "weight &optional radix")
366     {
367         public LispObject execute(LispObject arg) throws ConditionThrowable
368         {
369             int weight;
370             try {
371                 weight = ((Fixnum)arg).value;
372             }
373             catch (ClassCastException   e) {
374                 if (arg instanceof Bignum)
375                     return NIL;
376                 return signal(new TypeError(arg, Symbol.INTEGER));
377             }
378             if (weight < 10)
379                 return characters['0' + weight];
380             return NIL;
381         }
382 
383         public LispObject execute(LispObject first, LispObject second)
384             throws ConditionThrowable
385         {
386             int radix;
387             try {
388                 radix = ((Fixnum)second).value;
389             }
390             catch (ClassCastException   e) {
391                 radix = -1;
392             }
393             if (radix < 2 || radix > 36)
394                 return signal(new TypeError(second,
395                                             list3(Symbol.INTEGER, Fixnum.TWO,
396                                                   new Fixnum(36))));
397             int weight;
398             try {
399                 weight = ((Fixnum)first).value;
400             }
401             catch (ClassCastException   e) {
402                 if (first instanceof Bignum)
403                     return NIL;
404                 return signal(new TypeError(first, Symbol.INTEGER));
405             }
406             if (weight >= radix)
407                 return NIL;
408             if (weight < 10)
409                 return characters['0' + weight];
410             return characters['A' + weight - 10];
411         }
412     };
413 
414     // ### digit-char-p char &optional radix => weight
415     private static final Primitive DIGIT_CHAR_P =
416         new Primitive("digit-char-p", "char &optional radix")
417     {
418         public LispObject execute(LispObject arg) throws ConditionThrowable
419         {
420             try {
421                 int n = Character.digit(((LispCharacter)arg).value, 10);
422                 return n < 0 ? NIL : new Fixnum(n);
423             }
424             catch (ClassCastException   e) {
425                 return signal(new TypeError(arg, Symbol.CHARACTER));
426             }
427         }
428 
429         public LispObject execute(LispObject first, LispObject second)
430             throws ConditionThrowable
431         {
432             char c;
433             try {
434                 c = ((LispCharacter)first).value;
435             }
436             catch (ClassCastException   e) {
437                 return signal(new TypeError(first, Symbol.CHARACTER));
438             }
439             try {
440                 int radix = ((Fixnum)second).value;
441                 if (radix >= 2 && radix <= 36) {
442                     int n = Character.digit(c, radix);
443                     return n < 0 ? NIL : new Fixnum(n);
444                 }
445             }
446             catch (ClassCastException   e) {}
447             return signal(new TypeError(second,
448                                         list3(Symbol.INTEGER, Fixnum.TWO,
449                                               new Fixnum(36))));
450         }
451     };
452 
453     // ### standard-char-p
454     private static final Primitive1 STANDARD_CHAR_P =
455         new Primitive1("standard-char-p", "character")
456     {
457         public LispObject execute(LispObject arg) throws ConditionThrowable
458         {
459             return checkCharacter(arg).isStandardChar();
460         }
461     };
462 
463     // ### graphic-char-p
464     private static final Primitive1 GRAPHIC_CHAR_P =
465         new Primitive1("graphic-char-p", "char")
466     {
467         public LispObject execute(LispObject arg) throws ConditionThrowable
468         {
469             try {
470                 char c = ((LispCharacter)arg).value;
471                 if (c >= ' ' && c < 127)
472                     return T;
473                 return Character.isISOControl(c) ? NIL : T;
474             }
475             catch (ClassCastException   e) {
476                 return signal(new TypeError(arg, Symbol.CHARACTER));
477             }
478         }
479     };
480 
481     // ### alpha-char-p
482     private static final Primitive1 ALPHA_CHAR_P =
483         new Primitive1("alpha-char-p", "character")
484     {
485         public LispObject execute(LispObject arg) throws ConditionThrowable
486         {
487             try {
488                 return Character.isLetter(((LispCharacter)arg).value) ? T : NIL;
489             }
490             catch (ClassCastException   e) {
491                 return signal(new TypeError(arg, Symbol.CHARACTER));
492             }
493         }
494     };
495 
496     public static final int nameToChar(String   s)
497     {
498         String   lower = s.toLowerCase();
499         if (lower.equals("null"))
500             return 0;
501         if (lower.equals("backspace"))
502             return '\b';
503         if (lower.equals("tab"))
504             return '\t';
505         if (lower.equals("linefeed"))
506             return '\n';
507         if (lower.equals("newline"))
508             return '\n';
509         if (lower.equals("page"))
510             return '\f';
511         if (lower.equals("return"))
512             return '\r';
513         if (lower.equals("space"))
514             return ' ';
515         if (lower.equals("rubout"))
516             return 127;
517         // Unknown.
518         return -1;
519     }
520 
521     // ### name-char
522     private static final Primitive1 NAME_CHAR =
523         new Primitive1("name-char", "name")
524     {
525         public LispObject execute(LispObject arg) throws ConditionThrowable
526         {
527             String   s = arg.STRING().getStringValue();
528             int n = nameToChar(s);
529             return n >= 0 ? LispCharacter.getInstance((char)n) : NIL;
530         }
531     };
532 
533     public static final String   charToName(char c)
534     {
535         switch (c) {
536             case 0:
537                 return "Null";
538             case '\b':
539                 return "Backspace";
540             case '\t':
541                 return "Tab";
542             case '\n':
543                 return "Newline";
544             case '\f':
545                 return "Page";
546             case '\r':
547                 return "Return";
548             case ' ':
549                 return "Space";
550             case 127:
551                 return "Rubout";
552         }
553         return null;
554     }
555 
556     // ### char-name
557     private static final Primitive1 CHAR_NAME =
558         new Primitive1("char-name", "character")
559     {
560         public LispObject execute(LispObject arg) throws ConditionThrowable
561         {
562             String   name = charToName(LispCharacter.getValue(arg));
563             return name != null ? new SimpleString(name) : NIL;
564         }
565     };
566 }
567
A to Z: JavaDoc & Examples Daily Java News & Articles Open Source Projects Open Source Codes Free Computer Books Remove Frame
Popular Tags