libguile/keywords.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18
  19 \f
  20
  21 #include <string.h>
  22
  23 #include "libguile/_scm.h"
  24 #include "libguile/ports.h"
  25 #include "libguile/root.h"
  26 #include "libguile/smob.h"
  27 #include "libguile/hashtab.h"
  28
  29 #include "libguile/validate.h"
  30 #include "libguile/keywords.h"
  31 \f
  32
  33 scm_t_bits scm_tc16_keyword;
  34
  35 static int
  36 keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  37 {
  38   SCM symbol = SCM_KEYWORDSYM (exp);
  39
  40   scm_puts ("#:", port);
  41   scm_print_symbol_name (SCM_SYMBOL_CHARS (symbol) + 1,
  42                          SCM_SYMBOL_LENGTH (symbol) - 1,
  43                          port);
  44   scm_remember_upto_here_1 (symbol);
  45   return 1;
  46 }
  47
  48 SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
  49             (SCM symbol),
  50             "Make a keyword object from a @var{symbol} that starts with a dash.")
  51 #define FUNC_NAME s_scm_make_keyword_from_dash_symbol
  52 {
  53   SCM keyword;
  54
  55   SCM_ASSERT (SCM_SYMBOLP (symbol)
  56               && ('-' == SCM_SYMBOL_CHARS(symbol)[0]),
  57               symbol, SCM_ARG1, FUNC_NAME);
  58
  59   SCM_DEFER_INTS;
  60   keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F);
  61   if (SCM_FALSEP (keyword))
  62     {
  63       SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
  64       scm_hashq_set_x (scm_keyword_obarray, symbol, keyword);
  65     }
  66   SCM_ALLOW_INTS;
  67   return keyword;
  68 }
  69 #undef FUNC_NAME
  70
  71 SCM
  72 scm_c_make_keyword (char *s)
  73 {
  74   char *buf = scm_malloc (strlen (s) + 2);
  75   SCM symbol;
  76
  77   buf[0] = '-';
  78   strcpy (buf + 1, s);
  79   symbol = scm_str2symbol (buf);
  80   free (buf);
  81
  82   return scm_make_keyword_from_dash_symbol (symbol);
  83 }
  84
  85 SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
  86             (SCM obj),
  87             "Return @code{#t} if the argument @var{obj} is a keyword, else\n"
  88             "@code{#f}.")
  89 #define FUNC_NAME s_scm_keyword_p
  90 {
  91   return SCM_BOOL (SCM_KEYWORDP (obj));
  92 }
  93 #undef FUNC_NAME
  94
  95
  96 SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
  97             (SCM keyword),
  98             "Return the dash symbol for @var{keyword}.\n"
  99             "This is the inverse of @code{make-keyword-from-dash-symbol}.")
 100 #define FUNC_NAME s_scm_keyword_dash_symbol
 101 {
 102   SCM_VALIDATE_KEYWORD (1, keyword);
 103   return SCM_KEYWORDSYM (keyword);
 104 }
 105 #undef FUNC_NAME
 106
 107
 108
 109 void
 110 scm_init_keywords ()
 111 {
 112   scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
 113   scm_set_smob_mark (scm_tc16_keyword, scm_markcdr);
 114   scm_set_smob_print (scm_tc16_keyword, keyword_print);
 115
 116   scm_keyword_obarray = scm_c_make_hash_table (0);
 117 #include "libguile/keywords.x"
 118 }
 119
 120
 121 /*
 122   Local Variables:
 123   c-file-style: "gnu"
 124   End:
 125 */