001: /*
002: * LispCharacter.java
003: *
004: * Copyright (C) 2002-2004 Peter Graves
005: * $Id: LispCharacter.java,v 1.54 2004/09/08 18:10:58 piso Exp $
006: *
007: * This program is free software; you can redistribute it and/or
008: * modify it under the terms of the GNU General Public License
009: * as published by the Free Software Foundation; either version 2
010: * of the License, or (at your option) any later version.
011: *
012: * This program is distributed in the hope that it will be useful,
013: * but WITHOUT ANY WARRANTY; without even the implied warranty of
014: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
015: * GNU General Public License for more details.
016: *
017: * You should have received a copy of the GNU General Public License
018: * along with this program; if not, write to the Free Software
019: * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
020: */
021:
022: package org.armedbear.lisp;
023:
024: public final class LispCharacter extends LispObject {
025: private static final LispCharacter[] characters = new LispCharacter[CHAR_MAX];
026:
027: static {
028: for (int i = characters.length; i-- > 0;)
029: characters[i] = new LispCharacter((char) i);
030: }
031:
032: public final char value;
033:
034: public static LispCharacter getInstance(char c) {
035: try {
036: return characters[c];
037: } catch (ArrayIndexOutOfBoundsException e) {
038: return new LispCharacter(c);
039: }
040: }
041:
042: private LispCharacter(char c) {
043: this .value = c;
044: }
045:
046: public LispObject typeOf() {
047: return Symbol.CHARACTER;
048: }
049:
050: public LispClass classOf() {
051: return BuiltInClass.CHARACTER;
052: }
053:
054: public LispObject getDescription() {
055: StringBuffer sb = new StringBuffer("character #\\");
056: sb.append(value);
057: sb.append(" char-code #x");
058: sb.append(Integer.toHexString(value));
059: return new SimpleString(sb);
060: }
061:
062: public LispObject typep(LispObject type) throws ConditionThrowable {
063: if (type == Symbol.CHARACTER)
064: return T;
065: if (type == BuiltInClass.CHARACTER)
066: return T;
067: if (type == Symbol.BASE_CHAR)
068: return T;
069: if (type == Symbol.STANDARD_CHAR)
070: return isStandardChar();
071: return super .typep(type);
072: }
073:
074: public LispObject CHARACTERP() {
075: return T;
076: }
077:
078: public boolean characterp() {
079: return true;
080: }
081:
082: public LispObject STRING() {
083: return new SimpleString(value);
084: }
085:
086: public LispObject isStandardChar() {
087: if (value >= ' ' && value < 127)
088: return T;
089: if (value == '\n')
090: return T;
091: return NIL;
092: }
093:
094: public boolean eql(LispObject obj) {
095: if (this == obj)
096: return true;
097: if (obj instanceof LispCharacter) {
098: if (value == ((LispCharacter) obj).value)
099: return true;
100: }
101: return false;
102: }
103:
104: public boolean equal(LispObject obj) {
105: if (this == obj)
106: return true;
107: if (obj instanceof LispCharacter) {
108: if (value == ((LispCharacter) obj).value)
109: return true;
110: }
111: return false;
112: }
113:
114: public boolean equalp(LispObject obj) {
115: if (this == obj)
116: return true;
117: if (obj instanceof LispCharacter) {
118: if (value == ((LispCharacter) obj).value)
119: return true;
120: return Utilities.toLowerCase(value) == Utilities
121: .toLowerCase(((LispCharacter) obj).value);
122: }
123: return false;
124: }
125:
126: public static char getValue(LispObject obj)
127: throws ConditionThrowable {
128: try {
129: return ((LispCharacter) obj).getValue();
130: } catch (ClassCastException e) {
131: signal(new TypeError(obj, "character"));
132: // Not reached.
133: return 0;
134: }
135: }
136:
137: public final char getValue() {
138: return value;
139: }
140:
141: public Object javaInstance() {
142: return new Character(value);
143: }
144:
145: public Object javaInstance(Class c) {
146: return javaInstance();
147: }
148:
149: public int sxhash() {
150: return value;
151: }
152:
153: public int psxhash() {
154: return Character.toUpperCase(value);
155: }
156:
157: public final String writeToString() throws ConditionThrowable {
158: boolean printReadably = (_PRINT_READABLY_.symbolValue() != NIL);
159: // "Specifically, if *PRINT-READABLY* is true, printing proceeds as if
160: // *PRINT-ESCAPE*, *PRINT-ARRAY*, and *PRINT-GENSYM* were also true,
161: // and as if *PRINT-LENGTH*, *PRINT-LEVEL*, and *PRINT-LINES* were
162: // false."
163: boolean printEscape = printReadably
164: || (_PRINT_ESCAPE_.symbolValue() != NIL);
165: StringBuffer sb = new StringBuffer();
166: if (printEscape) {
167: sb.append("#\\");
168: switch (value) {
169: case 0:
170: sb.append("Null");
171: break;
172: case '\b':
173: sb.append("Backspace");
174: break;
175: case '\t':
176: sb.append("Tab");
177: break;
178: case '\n':
179: sb.append("Newline");
180: break;
181: case '\f':
182: sb.append("Page");
183: break;
184: case '\r':
185: sb.append("Return");
186: break;
187: case 127:
188: sb.append("Rubout");
189: break;
190: default:
191: sb.append(value);
192: break;
193: }
194: } else {
195: sb.append(value);
196: }
197: return sb.toString();
198: }
199:
200: private static final Primitive1 CHARACTER = new Primitive1(
201: "character", "character") {
202: public LispObject execute(LispObject arg)
203: throws ConditionThrowable {
204: if (arg instanceof LispCharacter)
205: return arg;
206: if (arg instanceof AbstractString) {
207: if (arg.length() == 1)
208: return ((AbstractString) arg).getRowMajor(0);
209: } else if (arg instanceof Symbol) {
210: String name = arg.getName();
211: if (name.length() == 1)
212: return getInstance(name.charAt(0));
213: }
214: return signal(new TypeError());
215: }
216: };
217:
218: // ### whitespacep
219: private static final Primitive1 WHITESPACEP = new Primitive1(
220: "whitespacep", PACKAGE_SYS, false) {
221: public LispObject execute(LispObject arg)
222: throws ConditionThrowable {
223: try {
224: return Character
225: .isWhitespace(((LispCharacter) arg).value) ? T
226: : NIL;
227: } catch (ClassCastException e) {
228: return signal(new TypeError(arg, Symbol.CHARACTER));
229: }
230: }
231: };
232:
233: // ### char-code
234: private static final Primitive1 CHAR_CODE = new Primitive1(
235: "char-code", "character") {
236: public LispObject execute(LispObject arg)
237: throws ConditionThrowable {
238: try {
239: return new Fixnum(((LispCharacter) arg).value);
240: } catch (ClassCastException e) {
241: return signal(new TypeError(arg, Symbol.CHARACTER));
242: }
243: }
244: };
245:
246: // ### char-int
247: private static final Primitive1 CHAR_INT = new Primitive1(
248: "char-int", "character") {
249: public LispObject execute(LispObject arg)
250: throws ConditionThrowable {
251: try {
252: return new Fixnum(((LispCharacter) arg).value);
253: } catch (ClassCastException e) {
254: return signal(new TypeError(arg, Symbol.CHARACTER));
255: }
256: }
257: };
258:
259: // ### code-char
260: private static final Primitive1 CODE_CHAR = new Primitive1(
261: "code-char", "code") {
262: public LispObject execute(LispObject arg)
263: throws ConditionThrowable {
264: try {
265: int n = ((Fixnum) arg).value;
266: if (n < CHAR_MAX)
267: return characters[n];
268: } catch (ClassCastException e) {
269: ; // SBCL signals a type error here: "not of type (UNSIGNED-BYTE 8)".
270: }
271: return NIL;
272: }
273: };
274:
275: // ### characterp
276: private static final Primitive1 CHARACTERP = new Primitive1(
277: "characterp", "object") {
278: public LispObject execute(LispObject arg)
279: throws ConditionThrowable {
280: return arg instanceof LispCharacter ? T : NIL;
281: }
282: };
283:
284: // ### both-case-p
285: private static final Primitive1 BOTH_CASE_P = new Primitive1(
286: "both-case-p", "character") {
287: public LispObject execute(LispObject arg)
288: throws ConditionThrowable {
289: char c = getValue(arg);
290: if (Character.isLowerCase(c) || Character.isUpperCase(c))
291: return T;
292: return NIL;
293: }
294: };
295:
296: // ### lower-case-p
297: private static final Primitive1 LOWER_CASE_P = new Primitive1(
298: "lower-case-p", "character") {
299: public LispObject execute(LispObject arg)
300: throws ConditionThrowable {
301: return Character.isLowerCase(getValue(arg)) ? T : NIL;
302: }
303: };
304:
305: // ### upper-case-p
306: private static final Primitive1 UPPER_CASE_P = new Primitive1(
307: "upper-case-p", "character") {
308: public LispObject execute(LispObject arg)
309: throws ConditionThrowable {
310: return Character.isUpperCase(getValue(arg)) ? T : NIL;
311: }
312: };
313:
314: // ### char-downcase
315: private static final Primitive1 CHAR_DOWNCASE = new Primitive1(
316: "char-downcase", "character") {
317: public LispObject execute(LispObject arg)
318: throws ConditionThrowable {
319: return getInstance(Utilities.toLowerCase(getValue(arg)));
320: }
321: };
322:
323: // ### char-upcase
324: private static final Primitive1 CHAR_UPCASE = new Primitive1(
325: "char-upcase", "character") {
326: public LispObject execute(LispObject arg)
327: throws ConditionThrowable {
328: return getInstance(Utilities.toUpperCase(getValue(arg)));
329: }
330: };
331:
332: // ### digit-char
333: private static final Primitive DIGIT_CHAR = new Primitive(
334: "digit-char", "weight &optional radix") {
335: public LispObject execute(LispObject arg)
336: throws ConditionThrowable {
337: int weight;
338: try {
339: weight = ((Fixnum) arg).value;
340: } catch (ClassCastException e) {
341: if (arg instanceof Bignum)
342: return NIL;
343: return signal(new TypeError(arg, Symbol.INTEGER));
344: }
345: if (weight < 10)
346: return characters['0' + weight];
347: return NIL;
348: }
349:
350: public LispObject execute(LispObject first, LispObject second)
351: throws ConditionThrowable {
352: int radix;
353: try {
354: radix = ((Fixnum) second).value;
355: } catch (ClassCastException e) {
356: radix = -1;
357: }
358: if (radix < 2 || radix > 36)
359: return signal(new TypeError(second, list3(
360: Symbol.INTEGER, Fixnum.TWO, new Fixnum(36))));
361: int weight;
362: try {
363: weight = ((Fixnum) first).value;
364: } catch (ClassCastException e) {
365: if (first instanceof Bignum)
366: return NIL;
367: return signal(new TypeError(first, Symbol.INTEGER));
368: }
369: if (weight >= radix)
370: return NIL;
371: if (weight < 10)
372: return characters['0' + weight];
373: return characters['A' + weight - 10];
374: }
375: };
376:
377: // ### digit-char-p char &optional radix => weight
378: private static final Primitive DIGIT_CHAR_P = new Primitive(
379: "digit-char-p", "char &optional radix") {
380: public LispObject execute(LispObject arg)
381: throws ConditionThrowable {
382: try {
383: int n = Character
384: .digit(((LispCharacter) arg).value, 10);
385: return n < 0 ? NIL : new Fixnum(n);
386: } catch (ClassCastException e) {
387: return signal(new TypeError(arg, Symbol.CHARACTER));
388: }
389: }
390:
391: public LispObject execute(LispObject first, LispObject second)
392: throws ConditionThrowable {
393: char c;
394: try {
395: c = ((LispCharacter) first).value;
396: } catch (ClassCastException e) {
397: return signal(new TypeError(first, Symbol.CHARACTER));
398: }
399: try {
400: int radix = ((Fixnum) second).value;
401: if (radix >= 2 && radix <= 36) {
402: int n = Character.digit(c, radix);
403: return n < 0 ? NIL : new Fixnum(n);
404: }
405: } catch (ClassCastException e) {
406: }
407: return signal(new TypeError(second, list3(Symbol.INTEGER,
408: Fixnum.TWO, new Fixnum(36))));
409: }
410: };
411:
412: // ### standard-char-p
413: private static final Primitive1 STANDARD_CHAR_P = new Primitive1(
414: "standard-char-p", "character") {
415: public LispObject execute(LispObject arg)
416: throws ConditionThrowable {
417: return checkCharacter(arg).isStandardChar();
418: }
419: };
420:
421: // ### graphic-char-p
422: private static final Primitive1 GRAPHIC_CHAR_P = new Primitive1(
423: "graphic-char-p", "char") {
424: public LispObject execute(LispObject arg)
425: throws ConditionThrowable {
426: try {
427: char c = ((LispCharacter) arg).value;
428: if (c >= ' ' && c < 127)
429: return T;
430: return Character.isISOControl(c) ? NIL : T;
431: } catch (ClassCastException e) {
432: return signal(new TypeError(arg, Symbol.CHARACTER));
433: }
434: }
435: };
436:
437: // ### alpha-char-p
438: private static final Primitive1 ALPHA_CHAR_P = new Primitive1(
439: "alpha-char-p", "character") {
440: public LispObject execute(LispObject arg)
441: throws ConditionThrowable {
442: try {
443: return Character.isLetter(((LispCharacter) arg).value) ? T
444: : NIL;
445: } catch (ClassCastException e) {
446: return signal(new TypeError(arg, Symbol.CHARACTER));
447: }
448: }
449: };
450:
451: public static final int nameToChar(String s) {
452: String lower = s.toLowerCase();
453: if (lower.equals("null"))
454: return 0;
455: if (lower.equals("backspace"))
456: return '\b';
457: if (lower.equals("tab"))
458: return '\t';
459: if (lower.equals("linefeed"))
460: return '\n';
461: if (lower.equals("newline"))
462: return '\n';
463: if (lower.equals("page"))
464: return '\f';
465: if (lower.equals("return"))
466: return '\r';
467: if (lower.equals("space"))
468: return ' ';
469: if (lower.equals("rubout"))
470: return 127;
471: // Unknown.
472: return -1;
473: }
474:
475: // ### name-char
476: private static final Primitive1 NAME_CHAR = new Primitive1(
477: "name-char", "name") {
478: public LispObject execute(LispObject arg)
479: throws ConditionThrowable {
480: String s = arg.STRING().getStringValue();
481: int n = nameToChar(s);
482: return n >= 0 ? LispCharacter.getInstance((char) n) : NIL;
483: }
484: };
485:
486: public static final String charToName(char c) {
487: switch (c) {
488: case 0:
489: return "Null";
490: case '\b':
491: return "Backspace";
492: case '\t':
493: return "Tab";
494: case '\n':
495: return "Newline";
496: case '\f':
497: return "Page";
498: case '\r':
499: return "Return";
500: case ' ':
501: return "Space";
502: case 127:
503: return "Rubout";
504: }
505: return null;
506: }
507:
508: // ### char-name
509: private static final Primitive1 CHAR_NAME = new Primitive1(
510: "char-name", "character") {
511: public LispObject execute(LispObject arg)
512: throws ConditionThrowable {
513: String name = charToName(LispCharacter.getValue(arg));
514: return name != null ? new SimpleString(name) : NIL;
515: }
516: };
517: }
|