1: /*
    2:  * keyword.c - keyword 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: keyword.c,v 1.17 2007/03/02 07:39:13 shirok Exp $
   34:  */
   35: 
   36: #define LIBGAUCHE_BODY
   37: #include "gauche.h"
   38: 
   39: /*
   40:  * Keywords
   41:  */
   42: 
   43: static void keyword_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
   44: {
   45:     if (SCM_WRITE_MODE(ctx) != SCM_WRITE_DISPLAY) {
   46:         SCM_PUTC(':', port);
   47:     }
   48:     SCM_PUTS(SCM_KEYWORD(obj)->name, port);
   49:     return;
   50: }
   51: 
   52: SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_KeywordClass, keyword_print);
   53: 
   54: /* Global keyword table. */
   55: static struct {
   56:     ScmHashTable *table;
   57:     ScmInternalMutex mutex;
   58: } keywords = { NULL };
   59: 
   60: /* Returns a keyword whose name is NAME.  Note that preceding ':' is not
   61:  * a part of the keyword name.
   62:  */
   63: ScmObj Scm_MakeKeyword(ScmString *name)
   64: {
   65:     ScmHashEntry *e;
   66:     ScmObj r;
   67: 
   68:     (void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
   69:     e = Scm_HashTableGet(keywords.table, SCM_OBJ(name));
   70:     if (e) r = e->value;
   71:     else {
   72:         ScmKeyword *k = SCM_NEW(ScmKeyword);
   73:         SCM_SET_CLASS(k, SCM_CLASS_KEYWORD);
   74:         k->name = SCM_STRING(Scm_CopyString(name));
   75:         Scm_HashTablePut(keywords.table, SCM_OBJ(name), SCM_OBJ(k));
   76:         r = SCM_OBJ(k);
   77:     }
   78:     (void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
   79:     return r;
   80: }
   81: 
   82: ScmObj Scm_GetKeyword(ScmObj key, ScmObj list, ScmObj fallback)
   83: {
   84:     ScmObj cp;
   85:     SCM_FOR_EACH(cp, list) {
   86:         if (!SCM_PAIRP(SCM_CDR(cp))) {
   87:             Scm_Error("incomplete key list: %S", list);
   88:         }
   89:         if (key == SCM_CAR(cp)) return SCM_CADR(cp);
   90:         cp = SCM_CDR(cp);
   91:     }
   92:     if (SCM_UNBOUNDP(fallback)) {
   93:         Scm_Error("value for key %S is not provided: %S", key, list);
   94:     }
   95:     return fallback;
   96: }
   97: 
   98: ScmObj Scm_DeleteKeyword(ScmObj key, ScmObj list)
   99: {
  100:     ScmObj cp;
  101:     SCM_FOR_EACH(cp, list) {
  102:         if (!SCM_PAIRP(SCM_CDR(cp))) {
  103:             Scm_Error("incomplete key list: %S", list);
  104:         }
  105:         if (key == SCM_CAR(cp)) {
  106:             /* found */
  107:             ScmObj h = SCM_NIL, t = SCM_NIL;
  108:             ScmObj tail = Scm_DeleteKeyword(key, SCM_CDR(SCM_CDR(cp)));
  109:             ScmObj cp2;
  110:             SCM_FOR_EACH(cp2, list) {
  111:                 if (cp2 == cp) {
  112:                     SCM_APPEND(h, t, tail);
  113:                     return h;
  114:                 } else {
  115:                     SCM_APPEND1(h, t, SCM_CAR(cp2));
  116:                 }
  117:             }
  118:         }
  119:         cp = SCM_CDR(cp);
  120:     }
  121:     return list;
  122: }
  123: 
  124: ScmObj Scm_DeleteKeywordX(ScmObj key, ScmObj list)
  125: {
  126:     ScmObj cp, prev = SCM_FALSE;
  127:     SCM_FOR_EACH(cp, list) {
  128:         if (!SCM_PAIRP(SCM_CDR(cp))) {
  129:             Scm_Error("incomplete key list: %S", list);
  130:         }
  131:         if (key == SCM_CAR(cp)) {
  132:             /* found */
  133:             if (SCM_FALSEP(prev)) {
  134:                 /* we're at the head of list */
  135:                 return Scm_DeleteKeywordX(key, SCM_CDR(SCM_CDR(cp)));
  136:             } else {
  137:                 ScmObj tail = Scm_DeleteKeywordX(key, SCM_CDR(SCM_CDR(cp)));
  138:                 SCM_SET_CDR(prev, tail);
  139:                 return list;
  140:             }
  141:         }
  142:         cp = SCM_CDR(cp);
  143:         prev = cp;
  144:     }
  145:     return list;
  146: }
  147: 
  148: void Scm__InitKeyword(void)
  149: {
  150:     (void)SCM_INTERNAL_MUTEX_INIT(keywords.mutex);
  151:     keywords.table = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_STRING, 256));
  152: }