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

Last change on this file was 13461, checked in by ehuelsmann, 13 years ago

Print expected minimum and maximum argument list lengths in
WrongNumberOfArguments? program errors.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 19.2 KB
Line 
1/*
2 * Readtable.java
3 *
4 * Copyright (C) 2003-2007 Peter Graves
5 * $Id: Readtable.java 13461 2011-08-11 17:01:41Z 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
36import static org.armedbear.lisp.Lisp.*;
37import java.util.Iterator;
38
39public 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
54  public Readtable()
55  {
56    initialize();
57  }
58
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
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
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
174  public final LispObject typeOf()
175  {
176    return Symbol.READTABLE;
177  }
178
179  @Override
180  public final LispObject classOf()
181  {
182    return BuiltInClass.READTABLE;
183  }
184
185  @Override
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
195  public final LispObject getReadtableCase()
196  {
197    return readtableCase;
198  }
199
200  public final boolean isWhitespace(char c)
201  {
202    return getSyntaxType(c) == SYNTAX_TYPE_WHITESPACE;
203  }
204
205  public final byte getSyntaxType(char c)
206  {
207    return syntax.get(c);
208  }
209
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
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
244  public final LispObject getReaderMacroFunction(char c)
245  {
246    return readerMacroFunctions.get(c);
247  }
248
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
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
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
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
314    public DispatchTable()
315    {
316      functions = new CharHashMap<LispObject>(LispObject.class,null);
317    }
318
319    @SuppressWarnings("unchecked")
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 StandardGenericFunction)
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}
Note: See TracBrowser for help on using the repository browser.