1: /*
    2:  * symbol.c - symbol implementation
    3:  *
    4:  *   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
    5:  * 
    6:  *   Redistribution and use in source and binary forms, with or without
    7:  *   modification, are permitted provided that the following conditions
    8:  *   are met:
    9:  * 
   10:  *   1. Redistributions of source code must retain the above copyright
   11:  *      notice, this list of conditions and the following disclaimer.
   12:  *
   13:  *   2. Redistributions in binary form must reproduce the above copyright
   14:  *      notice, this list of conditions and the following disclaimer in the
   15:  *      documentation and/or other materials provided with the distribution.
   16:  *
   17:  *   3. Neither the name of the authors nor the names of its contributors
   18:  *      may be used to endorse or promote products derived from this
   19:  *      software without specific prior written permission.
   20:  *
   21:  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22:  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23:  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24:  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25:  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26:  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27:  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28:  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29:  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30:  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31:  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32:  *
   33:  *  $Id: symbol.c,v 1.40 2007/09/13 12:30:28 shirok Exp $
   34:  */
   35: 
   36: #define LIBGAUCHE_BODY
   37: #include "gauche.h"
   38: #include "gauche/builtin-syms.h"
   39: 
   40: /*-----------------------------------------------------------
   41:  * Symbols
   42:  */
   43: 
   44: static void symbol_print(ScmObj obj, ScmPort *port, ScmWriteContext *);
   45: SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_SymbolClass, symbol_print);
   46: 
   47: #define INITSYM(sym, nam)                       \
   48:     sym = SCM_NEW(ScmSymbol);                   \
   49:     SCM_SET_CLASS(sym, SCM_CLASS_SYMBOL);       \
   50:     sym->name = SCM_STRING(nam)
   51: 
   52: /* These two are global resource.  Must be protected in MT environment. */
   53: static ScmHashTable *obtable = NULL;   /* name -> symbol mapper */
   54: static int gensym_count = 0;
   55: 
   56: /* Intern */
   57: 
   58: ScmObj Scm_Intern(ScmString *name)
   59: {
   60:     ScmHashEntry *e = Scm_HashTableGet(obtable, SCM_OBJ(name));
   61:     if (e) return e->value;
   62:     else {
   63:         ScmObj n = Scm_CopyStringWithFlags(name, SCM_STRING_IMMUTABLE,
   64:                                            SCM_STRING_IMMUTABLE);
   65:         ScmSymbol *sym;
   66:         INITSYM(sym, n);
   67:         Scm_HashTablePut(obtable, n, SCM_OBJ(sym));
   68:         return SCM_OBJ(sym);
   69:     }
   70: }
   71: 
   72: /* Default prefix string. */
   73: static SCM_DEFINE_STRING_CONST(default_prefix, "G", 1, 1);
   74: 
   75: /* Returns uninterned symbol.
   76:    PREFIX can be NULL*/
   77: ScmObj Scm_Gensym(ScmString *prefix)
   78: {
   79:     ScmString *name;
   80:     ScmSymbol *sym;
   81:     char numbuf[50];
   82:     int nc;
   83: 
   84:     if (prefix == NULL) prefix = &default_prefix;
   85:     nc = snprintf(numbuf, 50, "%d", gensym_count++);
   86:     name = SCM_STRING(Scm_StringAppendC(prefix, numbuf, nc, nc));
   87:     INITSYM(sym, name);
   88:     return SCM_OBJ(sym);
   89: }
   90: 
   91: /* Print */
   92: 
   93: /* table of special chars.
   94:    bit 0: bad char for symbol to begin with
   95:    bit 1: bad char for symbol to contain
   96:    bit 2: bad char for symbol, and should be written as \nnn
   97:    bit 3: bad char for symbol, and should be written as \c
   98:    bit 4: may be escaped when case fold mode
   99:  */
  100: static char special[] = {
  101:  /* NUL .... */
  102:     7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
  103:  /* .... */
  104:     7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
  105:  /*    !  "  #  $  %  &  '  (  )  *  +  ,  -  .  /  */
  106:     3, 0, 3, 3, 0, 0, 0, 3, 3, 3, 0, 1, 3, 1, 1, 0,
  107:  /* 0  1  2  3  4  5  6  7  8  9  :  ;  <  =  >  ?  */
  108:     1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 0, 0, 0, 0,
  109:  /* @  A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  */
  110:     1, 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,
  111:  /* P  Q  R  S  T  U  V  W  X  Y  Z  [  \  ]  ^  _  */
  112:     16,16,16,16,16,16,16,16,16,16,16,3, 11,3, 0, 0,
  113:  /* `  a  b  c  d  e  f  g  h  i  j  k  l  m  n  o  */
  114:     3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  115:  /* p  q  r  s  t  u  v  w  x  y  z  {  |  }  ~  ^? */
  116:     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 11,3, 0, 7
  117: };
  118: 
  119: static void symbol_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
  120: {
  121:     if (SCM_WRITE_MODE(ctx) == SCM_WRITE_DISPLAY) {
  122:         SCM_PUTS(SCM_SYMBOL(obj)->name, port);
  123:     } else {
  124:         /* See if we have special characters, and use |-escape if necessary. */
  125:         /* TODO: For now, we regard chars over 0x80 is all "printable".
  126:            Need a more consistent mechanism. */
  127:         ScmString *snam = SCM_SYMBOL(obj)->name;
  128:         const ScmStringBody *b = SCM_STRING_BODY(snam);
  129:         const char *p = SCM_STRING_BODY_START(b), *q;
  130:         int siz = SCM_STRING_BODY_SIZE(b), i;
  131:         int escape = FALSE;
  132:         int case_mask =
  133:             ((SCM_WRITE_CASE(ctx) == SCM_WRITE_CASE_FOLD)? 0x12 : 0x02);
  134:         
  135:         if (siz == 0) {         /* special case */
  136:             SCM_PUTZ("||", -1, port);
  137:             return;
  138:         }
  139:         if (siz == 1 && (*p == '+' || *p == '-')) {
  140:             SCM_PUTC((unsigned)*p, port);
  141:             return;
  142:         }
  143:         if ((unsigned int)*p < 128 && (special[(unsigned int)*p]&1)) {
  144:             escape = TRUE;
  145:         } else {
  146:             for (i=0, q=p; i<siz; i++, q++) {
  147:                 if ((unsigned int)*q < 128
  148:                     && (special[(unsigned int)*q]&case_mask)) {
  149:                     escape = TRUE;
  150:                     break;
  151:                 }
  152:             }
  153:         }
  154:         if (escape) {
  155:             SCM_PUTC('|', port);
  156:             for (q=p; q<p+siz; ) {
  157:                 unsigned int ch;
  158:                 SCM_CHAR_GET(q, ch);
  159:                 q += SCM_CHAR_NBYTES(ch);
  160:                 if (ch < 128) {
  161:                     if (special[ch] & 8) {
  162:                         SCM_PUTC('\\', port);
  163:                         SCM_PUTC(ch, port);
  164:                     } else if (special[ch] & 4) {
  165:                         Scm_Printf(port, "\\x%02x", ch);
  166:                     } else {
  167:                         SCM_PUTC(ch, port);
  168:                     }
  169:                 } else {
  170:                     SCM_PUTC(ch, port);
  171:                 }
  172:             }
  173:             SCM_PUTC('|', port);
  174:             return;
  175:         } else {
  176:             SCM_PUTS(snam, port);
  177:         }
  178:     }
  179: }
  180: 
  181: /*
  182:  * Initialization
  183:  */
  184: 
  185: #include "builtin-syms.c"
  186: 
  187: void Scm__InitSymbol(void)
  188: {
  189:     obtable = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_STRING, 4096));
  190:     init_builtin_syms();
  191: }