1 /*
2  * Readtable.java
3  *
4  * Copyright (C) 2003-2007 Peter Graves
5  * $Id$
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 
34 package org.armedbear.lisp;
35 
36 import static org.armedbear.lisp.Lisp.*;
37 import java.util.Iterator;
38 
39 public class Readtable extends LispObject
40 {
41   public static final byte SYNTAX_TYPE_CONSTITUENT           = 0;
42   public static final byte SYNTAX_TYPE_WHITESPACE            = 1;
43   public static final byte SYNTAX_TYPE_TERMINATING_MACRO     = 2;
44   public static final byte SYNTAX_TYPE_NON_TERMINATING_MACRO = 3;
45   public static final byte SYNTAX_TYPE_SINGLE_ESCAPE         = 4;
46   public static final byte SYNTAX_TYPE_MULTIPLE_ESCAPE       = 5;
47 
48   protected final CharHashMap<Byte> syntax = new CharHashMap<Byte>(Byte.class,SYNTAX_TYPE_CONSTITUENT);
49   protected final CharHashMap<LispObject> readerMacroFunctions = new CharHashMap<LispObject>(LispObject.class,null);
50   protected final CharHashMap<DispatchTable> dispatchTables = new CharHashMap<DispatchTable>(DispatchTable.class,null);
51 
52   protected LispObject readtableCase;
53 
Readtable()54   public Readtable()
55   {
56     initialize();
57   }
58 
initialize()59   protected void initialize()
60   {
61     Byte[] syntax = this.syntax.constants;
62     syntax[9]    = SYNTAX_TYPE_WHITESPACE; // tab
63     syntax[10]   = SYNTAX_TYPE_WHITESPACE; // linefeed
64     syntax[12]   = SYNTAX_TYPE_WHITESPACE; // form feed
65     syntax[13]   = SYNTAX_TYPE_WHITESPACE; // return
66     syntax[' ']  = SYNTAX_TYPE_WHITESPACE;
67 
68     syntax['"']  = SYNTAX_TYPE_TERMINATING_MACRO;
69     syntax['\''] = SYNTAX_TYPE_TERMINATING_MACRO;
70     syntax['(']  = SYNTAX_TYPE_TERMINATING_MACRO;
71     syntax[')']  = SYNTAX_TYPE_TERMINATING_MACRO;
72     syntax[',']  = SYNTAX_TYPE_TERMINATING_MACRO;
73     syntax[';']  = SYNTAX_TYPE_TERMINATING_MACRO;
74     syntax['`']  = SYNTAX_TYPE_TERMINATING_MACRO;
75 
76     syntax['#']  = SYNTAX_TYPE_NON_TERMINATING_MACRO;
77 
78     syntax['\\'] = SYNTAX_TYPE_SINGLE_ESCAPE;
79     syntax['|']  = SYNTAX_TYPE_MULTIPLE_ESCAPE;
80 
81     LispObject[] readerMacroFunctions = this.readerMacroFunctions.constants;
82     readerMacroFunctions[';']  = LispReader.READ_COMMENT;
83     readerMacroFunctions['"']  = LispReader.READ_STRING;
84     readerMacroFunctions['(']  = LispReader.READ_LIST;
85     readerMacroFunctions[')']  = LispReader.READ_RIGHT_PAREN;
86     readerMacroFunctions['\''] = LispReader.READ_QUOTE;
87     readerMacroFunctions['#']  = LispReader.READ_DISPATCH_CHAR;
88 
89     // BACKQUOTE-MACRO and COMMA-MACRO are defined in backquote.lisp.
90     readerMacroFunctions['`']  = Symbol.BACKQUOTE_MACRO;
91     readerMacroFunctions[',']  = Symbol.COMMA_MACRO;
92 
93     DispatchTable dt = new DispatchTable();
94     LispObject[] dtfunctions = dt.functions.constants;
95     dtfunctions['(']  = LispReader.SHARP_LEFT_PAREN;
96     dtfunctions['*']  = LispReader.SHARP_STAR;
97     dtfunctions['.']  = LispReader.SHARP_DOT;
98     dtfunctions[':']  = LispReader.SHARP_COLON;
99     dtfunctions['A']  = LispReader.SHARP_A;
100     dtfunctions['B']  = LispReader.SHARP_B;
101     dtfunctions['C']  = LispReader.SHARP_C;
102     dtfunctions['O']  = LispReader.SHARP_O;
103     dtfunctions['P']  = LispReader.SHARP_P;
104     dtfunctions['R']  = LispReader.SHARP_R;
105     dtfunctions['S']  = LispReader.SHARP_S;
106     dtfunctions['X']  = LispReader.SHARP_X;
107     dtfunctions['\''] = LispReader.SHARP_QUOTE;
108     dtfunctions['\\'] = LispReader.SHARP_BACKSLASH;
109     dtfunctions['|']  = LispReader.SHARP_VERTICAL_BAR;
110     dtfunctions[')']  = LispReader.SHARP_ILLEGAL;
111     dtfunctions['<']  = LispReader.SHARP_ILLEGAL;
112     dtfunctions[' ']  = LispReader.SHARP_ILLEGAL;
113     dtfunctions[8]    = LispReader.SHARP_ILLEGAL; // backspace
114     dtfunctions[9]    = LispReader.SHARP_ILLEGAL; // tab
115     dtfunctions[10]   = LispReader.SHARP_ILLEGAL; // newline, linefeed
116     dtfunctions[12]   = LispReader.SHARP_ILLEGAL; // page
117     dtfunctions[13]   = LispReader.SHARP_ILLEGAL; // return
118 
119     dispatchTables.constants['#'] = dt;
120 
121     readtableCase = Keyword.UPCASE;
122   }
123 
Readtable(LispObject obj)124   public Readtable(LispObject obj)
125   {
126     Readtable rt;
127     if (obj == NIL)
128       rt = checkReadtable(STANDARD_READTABLE.symbolValue());
129     else
130       rt = checkReadtable(obj);
131     synchronized (rt)
132       {
133         copyReadtable(rt, this);
134       }
135   }
136 
137   // FIXME synchronization
copyReadtable(Readtable from, Readtable to)138   static void copyReadtable(Readtable from, Readtable to)
139   {
140     Iterator<Character> charIterator = from.syntax.getCharIterator();
141       while (charIterator.hasNext()) {
142         char c = charIterator.next();
143           Byte dt = from.syntax.get(c);
144           if (dt!=null) {
145               to.syntax.put(c, dt);
146           } else {
147               to.syntax.put(c, null);
148           }
149       }
150       charIterator = from.readerMacroFunctions.getCharIterator();
151       while (charIterator.hasNext()) {
152         char c = charIterator.next();
153           LispObject dt = from.readerMacroFunctions.get(c);
154           if (dt!=null) {
155               to.readerMacroFunctions.put(c, dt);
156           } else {
157               to.readerMacroFunctions.put(c, null);
158           }
159       }
160       charIterator = from.dispatchTables.getCharIterator();
161       while (charIterator.hasNext()) {
162         char c = charIterator.next();
163           DispatchTable dt = from.dispatchTables.get(c);
164           if (dt!=null) {
165               to.dispatchTables.put(c, new DispatchTable(dt));
166           } else {
167               to.dispatchTables.put(c, null);
168           }
169       }
170       to.readtableCase = from.readtableCase;
171   }
172 
173   @Override
typeOf()174   public final LispObject typeOf()
175   {
176     return Symbol.READTABLE;
177   }
178 
179   @Override
classOf()180   public final LispObject classOf()
181   {
182     return BuiltInClass.READTABLE;
183   }
184 
185   @Override
typep(LispObject type)186   public final LispObject typep(LispObject type)
187   {
188     if (type == Symbol.READTABLE)
189       return T;
190     if (type == BuiltInClass.READTABLE)
191       return T;
192     return super.typep(type);
193   }
194 
getReadtableCase()195   public final LispObject getReadtableCase()
196   {
197     return readtableCase;
198   }
199 
isWhitespace(char c)200   public final boolean isWhitespace(char c)
201   {
202     return getSyntaxType(c) == SYNTAX_TYPE_WHITESPACE;
203   }
204 
getSyntaxType(char c)205   public final byte getSyntaxType(char c)
206   {
207     return syntax.get(c);
208   }
209 
isInvalid(char c)210   public final boolean isInvalid(char c)
211   {
212     switch (c)
213       {
214       case 8:
215       case 9:
216       case 10:
217       case 12:
218       case 13:
219       case 32:
220       case 127:
221         return true;
222       default:
223         return false;
224       }
225   }
226 
checkInvalid(char c, Stream stream)227   public final void checkInvalid(char c, Stream stream)
228   {
229     // "... no mechanism is provided for changing the constituent trait of a
230     // character." (2.1.4.2)
231     if (isInvalid(c))
232       {
233         String name = LispCharacter.charToName(c);
234         StringBuilder sb = new StringBuilder("Invalid character");
235         if (name != null)
236           {
237             sb.append(" #\\");
238             sb.append(name);
239           }
240         error(new ReaderError(sb.toString(), stream));
241       }
242   }
243 
getReaderMacroFunction(char c)244   public final LispObject getReaderMacroFunction(char c)
245   {
246     return readerMacroFunctions.get(c);
247   }
248 
getMacroCharacter(char c)249   final LispObject getMacroCharacter(char c)
250   {
251     LispObject function = getReaderMacroFunction(c);
252     LispObject non_terminating_p;
253     if (function != null)
254       {
255         if (syntax.get(c) == SYNTAX_TYPE_NON_TERMINATING_MACRO)
256           non_terminating_p = T;
257         else
258           non_terminating_p = NIL;
259       }
260     else
261       {
262         function = NIL;
263         non_terminating_p = NIL;
264       }
265     return LispThread.currentThread().setValues(function, non_terminating_p);
266   }
267 
makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p)268   final void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p)
269   {
270     byte syntaxType;
271     if (non_terminating_p != NIL)
272       syntaxType = SYNTAX_TYPE_NON_TERMINATING_MACRO;
273     else
274       syntaxType = SYNTAX_TYPE_TERMINATING_MACRO;
275     // FIXME synchronization
276     syntax.put(dispChar,syntaxType);
277     readerMacroFunctions.put(dispChar, LispReader.READ_DISPATCH_CHAR);
278     dispatchTables.put(dispChar, new DispatchTable());
279   }
280 
getDispatchMacroCharacter(char dispChar, char subChar)281   public final LispObject getDispatchMacroCharacter(char dispChar, char subChar)
282 
283   {
284     DispatchTable dispatchTable = dispatchTables.get(dispChar);
285     if (dispatchTable == null)
286       {
287         LispCharacter c = LispCharacter.getInstance(dispChar);
288         return error(new LispError(c.princToString() +
289                                     " is not a dispatch character."));
290       }
291     LispObject function =
292       dispatchTable.functions.get(LispCharacter.toUpperCase(subChar));
293     return (function != null) ? function : NIL;
294   }
295 
setDispatchMacroCharacter(char dispChar, char subChar, LispObject function)296   public final void setDispatchMacroCharacter(char dispChar, char subChar,
297                                         LispObject function)
298 
299   {
300     DispatchTable dispatchTable = dispatchTables.get(dispChar);
301     if (dispatchTable == null)
302       {
303         LispCharacter c = LispCharacter.getInstance(dispChar);
304         error(new LispError(c.princToString() +
305                              " is not a dispatch character."));
306       }
307     dispatchTable.functions.put(LispCharacter.toUpperCase(subChar), function);
308   }
309 
310   protected static class DispatchTable
311   {
312 	protected final CharHashMap<LispObject> functions;
313 
DispatchTable()314     public DispatchTable()
315     {
316       functions = new CharHashMap<LispObject>(LispObject.class,null);
317     }
318 
319     @SuppressWarnings("unchecked")
DispatchTable(DispatchTable dt)320     public DispatchTable(DispatchTable dt)
321     {
322       functions = (CharHashMap<LispObject>) dt.functions.clone();
323     }
324   }
325 
326   // ### readtablep
327   private static final Primitive READTABLEP =
328     new Primitive("readtablep", "object")
329     {
330       @Override
331       public LispObject execute(LispObject arg)
332       {
333         return arg instanceof Readtable ? T : NIL;
334       }
335     };
336 
337   // ### copy-readtable
338   private static final Primitive COPY_READTABLE =
339     new Primitive("copy-readtable", "&optional from-readtable to-readtable")
340     {
341       @Override
342       public LispObject execute()
343       {
344         return new Readtable(currentReadtable());
345       }
346 
347       @Override
348       public LispObject execute(LispObject arg)
349       {
350         return new Readtable(arg);
351       }
352 
353       @Override
354       public LispObject execute(LispObject first, LispObject second)
355 
356       {
357         Readtable from = designator_readtable(first);
358         if (second == NIL)
359           return new Readtable(from);
360         Readtable to = checkReadtable(second);
361         copyReadtable(from, to);
362         return to;
363       }
364     };
365 
366   // ### get-macro-character char &optional readtable
367   // => function, non-terminating-p
368   private static final Primitive GET_MACRO_CHARACTER =
369     new Primitive("get-macro-character", "char &optional readtable")
370     {
371       @Override
372       public LispObject execute(LispObject arg)
373       {
374         char c = LispCharacter.getValue(arg);
375         Readtable rt = currentReadtable();
376         return rt.getMacroCharacter(c);
377       }
378 
379       @Override
380       public LispObject execute(LispObject first, LispObject second)
381 
382       {
383         char c = LispCharacter.getValue(first);
384         Readtable rt = designator_readtable(second);
385         return rt.getMacroCharacter(c);
386       }
387     };
388 
389   // ### set-macro-character char new-function &optional non-terminating-p readtable
390   // => t
391   private static final Primitive SET_MACRO_CHARACTER =
392     new Primitive("set-macro-character",
393                   "char new-function &optional non-terminating-p readtable")
394     {
395       @Override
396       public LispObject execute(LispObject first, LispObject second)
397 
398       {
399         return execute(first, second, NIL, currentReadtable());
400       }
401 
402       @Override
403       public LispObject execute(LispObject first, LispObject second,
404                                 LispObject third)
405 
406       {
407         return execute(first, second, third, currentReadtable());
408       }
409 
410       @Override
411       public LispObject execute(LispObject first, LispObject second,
412                                 LispObject third, LispObject fourth)
413 
414       {
415         char c = LispCharacter.getValue(first);
416         final LispObject designator;
417         if (second instanceof Function
418             || second instanceof FuncallableStandardObject)
419           designator = second;
420         else if (second instanceof Symbol)
421           designator = second;
422         else
423           return error(new LispError(second.princToString() +
424                                       " does not designate a function."));
425         byte syntaxType;
426         if (third != NIL)
427           syntaxType = SYNTAX_TYPE_NON_TERMINATING_MACRO;
428         else
429           syntaxType = SYNTAX_TYPE_TERMINATING_MACRO;
430         Readtable rt = designator_readtable(fourth);
431         // REVIEW synchronization
432         rt.syntax.put(c, syntaxType);
433         rt.readerMacroFunctions.put(c, designator);
434         return T;
435       }
436     };
437 
438   // ### make-dispatch-macro-character char &optional non-terminating-p readtable
439   // => t
440   private static final Primitive MAKE_DISPATCH_MACRO_CHARACTER =
441     new Primitive("make-dispatch-macro-character",
442                   "char &optional non-terminating-p readtable")
443     {
444       @Override
445       public LispObject execute(LispObject[] args)
446       {
447         if (args.length < 1 || args.length > 3)
448           return error(new WrongNumberOfArgumentsException(this, 1, 3));
449         char dispChar = LispCharacter.getValue(args[0]);
450         LispObject non_terminating_p;
451         if (args.length > 1)
452           non_terminating_p = args[1];
453         else
454           non_terminating_p = NIL;
455         Readtable readtable;
456         if (args.length == 3)
457           readtable = checkReadtable(args[2]);
458         else
459           readtable = currentReadtable();
460         readtable.makeDispatchMacroCharacter(dispChar, non_terminating_p);
461         return T;
462       }
463     };
464 
465   // ### get-dispatch-macro-character disp-char sub-char &optional readtable
466   // => function
467   private static final Primitive GET_DISPATCH_MACRO_CHARACTER =
468     new Primitive("get-dispatch-macro-character",
469                   "disp-char sub-char &optional readtable")
470     {
471       @Override
472       public LispObject execute(LispObject[] args)
473       {
474         if (args.length < 2 || args.length > 3)
475           return error(new WrongNumberOfArgumentsException(this, 1, 3));
476         char dispChar = LispCharacter.getValue(args[0]);
477         char subChar = LispCharacter.getValue(args[1]);
478         Readtable readtable;
479         if (args.length == 3)
480           readtable = designator_readtable(args[2]);
481         else
482           readtable = currentReadtable();
483         return readtable.getDispatchMacroCharacter(dispChar, subChar);
484       }
485     };
486 
487   // ### set-dispatch-macro-character disp-char sub-char new-function &optional readtable
488   // => t
489   private static final Primitive SET_DISPATCH_MACRO_CHARACTER =
490     new Primitive("set-dispatch-macro-character",
491                   "disp-char sub-char new-function &optional readtable")
492     {
493       @Override
494       public LispObject execute(LispObject[] args)
495       {
496         if (args.length < 3 || args.length > 4)
497           return error(new WrongNumberOfArgumentsException(this, 3, 4));
498         char dispChar = LispCharacter.getValue(args[0]);
499         char subChar = LispCharacter.getValue(args[1]);
500         LispObject function = coerceToFunction(args[2]);
501         Readtable readtable;
502         if (args.length == 4)
503           readtable = designator_readtable(args[3]);
504         else
505           readtable = currentReadtable();
506         readtable.setDispatchMacroCharacter(dispChar, subChar, function);
507         return T;
508       }
509     };
510 
511   // ### set-syntax-from-char to-char from-char &optional to-readtable from-readtable
512   // => t
513   private static final Primitive SET_SYNTAX_FROM_CHAR =
514     new Primitive("set-syntax-from-char",
515                   "to-char from-char &optional to-readtable from-readtable")
516     {
517       @Override
518       public LispObject execute(LispObject[] args)
519       {
520         if (args.length < 2 || args.length > 4)
521           return error(new WrongNumberOfArgumentsException(this, 2, 4));
522         char toChar = LispCharacter.getValue(args[0]);
523         char fromChar = LispCharacter.getValue(args[1]);
524         Readtable toReadtable;
525         if (args.length > 2)
526           toReadtable = checkReadtable(args[2]);
527         else
528           toReadtable = currentReadtable();
529         Readtable fromReadtable;
530         if (args.length > 3)
531           fromReadtable = designator_readtable(args[3]);
532         else
533           fromReadtable = checkReadtable(STANDARD_READTABLE.symbolValue());
534         // REVIEW synchronization
535         toReadtable.syntax.put(toChar, fromReadtable.syntax.get(fromChar));
536         toReadtable.readerMacroFunctions.put(toChar,
537         		fromReadtable.readerMacroFunctions.get(fromChar));
538         // "If the character is a dispatching macro character, its entire
539         // dispatch table of reader macro functions is copied."
540         DispatchTable found = fromReadtable.dispatchTables.get(fromChar);
541         if (found!=null)
542         	toReadtable.dispatchTables.put(toChar, new DispatchTable(found));
543         else
544             // Don't leave behind dispatch tables when fromChar
545             // doesn't have one
546         	toReadtable.dispatchTables.put(toChar, null);
547         return T;
548       }
549     };
550 
551   // ### readtable-case readtable => mode
552   private static final Primitive READTABLE_CASE =
553     new Primitive("readtable-case", "readtable")
554     {
555       @Override
556       public LispObject execute(LispObject arg)
557       {
558           return checkReadtable(arg).readtableCase;
559       }
560     };
561 
562   // ### %set-readtable-case readtable new-mode => new-mode
563   private static final Primitive _SET_READTABLE_CASE =
564     new Primitive("%set-readtable-case", PACKAGE_SYS, false,
565                   "readtable new-mode")
566     {
567       @Override
568       public LispObject execute(LispObject first, LispObject second)
569 
570       {
571             final Readtable readtable = checkReadtable(first);
572             if (second == Keyword.UPCASE || second == Keyword.DOWNCASE ||
573                 second == Keyword.INVERT || second == Keyword.PRESERVE)
574               {
575                 readtable.readtableCase = second;
576                 return second;
577               }
578             return type_error(second, list(Symbol.MEMBER,
579                                                  Keyword.INVERT,
580                                                  Keyword.PRESERVE,
581                                                  Keyword.DOWNCASE,
582                                                  Keyword.UPCASE));
583       }
584     };
585 }
586