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

Last change on this file was 12749, checked in by Mark Evenson, 14 years ago

Undo previous commmit.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 19.3 KB
Line 
1/*
2 * Readtable.java
3 *
4 * Copyright (C) 2003-2007 Peter Graves
5 * $Id: Readtable.java 12749 2010-06-09 11:27:42Z mevenson $
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  @Override
196  public final String toString()
197  {
198    return unreadableString("READTABLE");
199  }
200
201  public final LispObject getReadtableCase()
202  {
203    return readtableCase;
204  }
205
206  public final boolean isWhitespace(char c)
207  {
208    return getSyntaxType(c) == SYNTAX_TYPE_WHITESPACE;
209  }
210
211  public final byte getSyntaxType(char c)
212  {
213    return syntax.get(c);
214  }
215
216  public final boolean isInvalid(char c)
217  {
218    switch (c)
219      {
220      case 8:
221      case 9:
222      case 10:
223      case 12:
224      case 13:
225      case 32:
226      case 127:
227        return true;
228      default:
229        return false;
230      }
231  }
232
233  public final void checkInvalid(char c, Stream stream)
234  {
235    // "... no mechanism is provided for changing the constituent trait of a
236    // character." (2.1.4.2)
237    if (isInvalid(c))
238      {
239        String name = LispCharacter.charToName(c);
240        StringBuilder sb = new StringBuilder("Invalid character");
241        if (name != null)
242          {
243            sb.append(" #\\");
244            sb.append(name);
245          }
246        error(new ReaderError(sb.toString(), stream));
247      }
248  }
249
250  public final LispObject getReaderMacroFunction(char c)
251  {
252    return readerMacroFunctions.get(c);
253  }
254
255  final LispObject getMacroCharacter(char c)
256  {
257    LispObject function = getReaderMacroFunction(c);
258    LispObject non_terminating_p;
259    if (function != null)
260      {
261        if (syntax.get(c) == SYNTAX_TYPE_NON_TERMINATING_MACRO)
262          non_terminating_p = T;
263        else
264          non_terminating_p = NIL;
265      }
266    else
267      {
268        function = NIL;
269        non_terminating_p = NIL;
270      }
271    return LispThread.currentThread().setValues(function, non_terminating_p);
272  }
273
274  final void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p)
275  {
276    byte syntaxType;
277    if (non_terminating_p != NIL)
278      syntaxType = SYNTAX_TYPE_NON_TERMINATING_MACRO;
279    else
280      syntaxType = SYNTAX_TYPE_TERMINATING_MACRO;
281    // FIXME synchronization
282    syntax.put(dispChar,syntaxType);
283    readerMacroFunctions.put(dispChar, LispReader.READ_DISPATCH_CHAR);
284    dispatchTables.put(dispChar, new DispatchTable());
285  }
286
287  public final LispObject getDispatchMacroCharacter(char dispChar, char subChar)
288
289  {
290    DispatchTable dispatchTable = dispatchTables.get(dispChar);
291    if (dispatchTable == null)
292      {
293        LispCharacter c = LispCharacter.getInstance(dispChar);
294        return error(new LispError(c.writeToString() +
295                                    " is not a dispatch character."));
296      }
297    LispObject function =
298      dispatchTable.functions.get(LispCharacter.toUpperCase(subChar));
299    return (function != null) ? function : NIL;
300  }
301
302  public final void setDispatchMacroCharacter(char dispChar, char subChar,
303                                        LispObject function)
304
305  {
306    DispatchTable dispatchTable = dispatchTables.get(dispChar);
307    if (dispatchTable == null)
308      {
309        LispCharacter c = LispCharacter.getInstance(dispChar);
310        error(new LispError(c.writeToString() +
311                             " is not a dispatch character."));
312      }
313    dispatchTable.functions.put(LispCharacter.toUpperCase(subChar), function);
314  }
315
316  protected static class DispatchTable
317  {
318  protected final CharHashMap<LispObject> functions;
319
320    public DispatchTable()
321    {
322      functions = new CharHashMap<LispObject>(LispObject.class,null);
323    }
324
325    @SuppressWarnings("unchecked")
326    public DispatchTable(DispatchTable dt)
327    {
328      functions = (CharHashMap<LispObject>) dt.functions.clone();
329    }
330  }
331
332  // ### readtablep
333  private static final Primitive READTABLEP =
334    new Primitive("readtablep", "object")
335    {
336      @Override
337      public LispObject execute(LispObject arg)
338      {
339        return arg instanceof Readtable ? T : NIL;
340      }
341    };
342
343  // ### copy-readtable
344  private static final Primitive COPY_READTABLE =
345    new Primitive("copy-readtable", "&optional from-readtable to-readtable")
346    {
347      @Override
348      public LispObject execute()
349      {
350        return new Readtable(currentReadtable());
351      }
352
353      @Override
354      public LispObject execute(LispObject arg)
355      {
356        return new Readtable(arg);
357      }
358
359      @Override
360      public LispObject execute(LispObject first, LispObject second)
361
362      {
363        Readtable from = designator_readtable(first);
364        if (second == NIL)
365          return new Readtable(from);
366        Readtable to = checkReadtable(second);
367        copyReadtable(from, to);
368        return to;
369      }
370    };
371
372  // ### get-macro-character char &optional readtable
373  // => function, non-terminating-p
374  private static final Primitive GET_MACRO_CHARACTER =
375    new Primitive("get-macro-character", "char &optional readtable")
376    {
377      @Override
378      public LispObject execute(LispObject arg)
379      {
380        char c = LispCharacter.getValue(arg);
381        Readtable rt = currentReadtable();
382        return rt.getMacroCharacter(c);
383      }
384
385      @Override
386      public LispObject execute(LispObject first, LispObject second)
387
388      {
389        char c = LispCharacter.getValue(first);
390        Readtable rt = designator_readtable(second);
391        return rt.getMacroCharacter(c);
392      }
393    };
394
395  // ### set-macro-character char new-function &optional non-terminating-p readtable
396  // => t
397  private static final Primitive SET_MACRO_CHARACTER =
398    new Primitive("set-macro-character",
399                  "char new-function &optional non-terminating-p readtable")
400    {
401      @Override
402      public LispObject execute(LispObject first, LispObject second)
403
404      {
405        return execute(first, second, NIL, currentReadtable());
406      }
407
408      @Override
409      public LispObject execute(LispObject first, LispObject second,
410                                LispObject third)
411
412      {
413        return execute(first, second, third, currentReadtable());
414      }
415
416      @Override
417      public LispObject execute(LispObject first, LispObject second,
418                                LispObject third, LispObject fourth)
419
420      {
421        char c = LispCharacter.getValue(first);
422        final LispObject designator;
423        if (second instanceof Function
424            || second instanceof StandardGenericFunction)
425          designator = second;
426        else if (second instanceof Symbol)
427          designator = second;
428        else
429          return error(new LispError(second.writeToString() +
430                                      " does not designate a function."));
431        byte syntaxType;
432        if (third != NIL)
433          syntaxType = SYNTAX_TYPE_NON_TERMINATING_MACRO;
434        else
435          syntaxType = SYNTAX_TYPE_TERMINATING_MACRO;
436        Readtable rt = designator_readtable(fourth);
437        // REVIEW synchronization
438        rt.syntax.put(c, syntaxType);
439        rt.readerMacroFunctions.put(c, designator);
440        return T;
441      }
442    };
443
444  // ### make-dispatch-macro-character char &optional non-terminating-p readtable
445  // => t
446  private static final Primitive MAKE_DISPATCH_MACRO_CHARACTER =
447    new Primitive("make-dispatch-macro-character",
448                  "char &optional non-terminating-p readtable")
449    {
450      @Override
451      public LispObject execute(LispObject[] args)
452      {
453        if (args.length < 1 || args.length > 3)
454          return error(new WrongNumberOfArgumentsException(this));
455        char dispChar = LispCharacter.getValue(args[0]);
456        LispObject non_terminating_p;
457        if (args.length > 1)
458          non_terminating_p = args[1];
459        else
460          non_terminating_p = NIL;
461        Readtable readtable;
462        if (args.length == 3)
463          readtable = checkReadtable(args[2]);
464        else
465          readtable = currentReadtable();
466        readtable.makeDispatchMacroCharacter(dispChar, non_terminating_p);
467        return T;
468      }
469    };
470
471  // ### get-dispatch-macro-character disp-char sub-char &optional readtable
472  // => function
473  private static final Primitive GET_DISPATCH_MACRO_CHARACTER =
474    new Primitive("get-dispatch-macro-character",
475                  "disp-char sub-char &optional readtable")
476    {
477      @Override
478      public LispObject execute(LispObject[] args)
479      {
480        if (args.length < 2 || args.length > 3)
481          return error(new WrongNumberOfArgumentsException(this));
482        char dispChar = LispCharacter.getValue(args[0]);
483        char subChar = LispCharacter.getValue(args[1]);
484        Readtable readtable;
485        if (args.length == 3)
486          readtable = designator_readtable(args[2]);
487        else
488          readtable = currentReadtable();
489        return readtable.getDispatchMacroCharacter(dispChar, subChar);
490      }
491    };
492
493  // ### set-dispatch-macro-character disp-char sub-char new-function &optional readtable
494  // => t
495  private static final Primitive SET_DISPATCH_MACRO_CHARACTER =
496    new Primitive("set-dispatch-macro-character",
497                  "disp-char sub-char new-function &optional readtable")
498    {
499      @Override
500      public LispObject execute(LispObject[] args)
501      {
502        if (args.length < 3 || args.length > 4)
503          return error(new WrongNumberOfArgumentsException(this));
504        char dispChar = LispCharacter.getValue(args[0]);
505        char subChar = LispCharacter.getValue(args[1]);
506        LispObject function = coerceToFunction(args[2]);
507        Readtable readtable;
508        if (args.length == 4)
509          readtable = designator_readtable(args[3]);
510        else
511          readtable = currentReadtable();
512        readtable.setDispatchMacroCharacter(dispChar, subChar, function);
513        return T;
514      }
515    };
516
517  // ### set-syntax-from-char to-char from-char &optional to-readtable from-readtable
518  // => t
519  private static final Primitive SET_SYNTAX_FROM_CHAR =
520    new Primitive("set-syntax-from-char",
521                  "to-char from-char &optional to-readtable from-readtable")
522    {
523      @Override
524      public LispObject execute(LispObject[] args)
525      {
526        if (args.length < 2 || args.length > 4)
527          return error(new WrongNumberOfArgumentsException(this));
528        char toChar = LispCharacter.getValue(args[0]);
529        char fromChar = LispCharacter.getValue(args[1]);
530        Readtable toReadtable;
531        if (args.length > 2)
532          toReadtable = checkReadtable(args[2]);
533        else
534          toReadtable = currentReadtable();
535        Readtable fromReadtable;
536        if (args.length > 3)
537          fromReadtable = designator_readtable(args[3]);
538        else
539          fromReadtable = checkReadtable(STANDARD_READTABLE.symbolValue());
540        // REVIEW synchronization
541        toReadtable.syntax.put(toChar, fromReadtable.syntax.get(fromChar));
542        toReadtable.readerMacroFunctions.put(toChar,
543            fromReadtable.readerMacroFunctions.get(fromChar));
544        // "If the character is a dispatching macro character, its entire
545        // dispatch table of reader macro functions is copied."
546        DispatchTable found = fromReadtable.dispatchTables.get(fromChar);
547        if (found!=null)
548          toReadtable.dispatchTables.put(toChar, new DispatchTable(found));         
549        else
550            // Don't leave behind dispatch tables when fromChar
551            // doesn't have one
552          toReadtable.dispatchTables.put(toChar, null);
553        return T;
554      }
555    };
556
557  // ### readtable-case readtable => mode
558  private static final Primitive READTABLE_CASE =
559    new Primitive("readtable-case", "readtable")
560    {
561      @Override
562      public LispObject execute(LispObject arg)
563      {
564          return checkReadtable(arg).readtableCase;
565      }
566    };
567
568  // ### %set-readtable-case readtable new-mode => new-mode
569  private static final Primitive _SET_READTABLE_CASE =
570    new Primitive("%set-readtable-case", PACKAGE_SYS, false,
571                  "readtable new-mode")
572    {
573      @Override
574      public LispObject execute(LispObject first, LispObject second)
575
576      {
577            final Readtable readtable = checkReadtable(first);
578            if (second == Keyword.UPCASE || second == Keyword.DOWNCASE ||
579                second == Keyword.INVERT || second == Keyword.PRESERVE)
580              {
581                readtable.readtableCase = second;
582                return second;
583              }
584            return type_error(second, list(Symbol.MEMBER,
585                                                 Keyword.INVERT,
586                                                 Keyword.PRESERVE,
587                                                 Keyword.DOWNCASE,
588                                                 Keyword.UPCASE));
589      }
590    };
591}
Note: See TracBrowser for help on using the repository browser.