libguile/keywords.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 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 #include "libguile/strings.h"
  32
  33 \f
  34
  35 scm_t_bits scm_tc16_keyword;
  36
  37 static int
  38 keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  39 {
  40   SCM symbol = SCM_KEYWORDSYM (exp);
  41
  42   scm_puts ("#:", port);
  43   scm_print_symbol_name (scm_i_symbol_chars (symbol) + 1,
  44                          scm_i_symbol_length (symbol) - 1,
  45                          port);
  46   scm_remember_upto_here_1 (symbol);
  47   return 1;
  48 }
  49
  50 SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
  51             (SCM symbol),
  52             "Make a keyword object from a @var{symbol} that starts with a dash.")
  53 #define FUNC_NAME s_scm_make_keyword_from_dash_symbol
  54 {
  55   SCM keyword;
  56
  57   SCM_ASSERT (scm_is_symbol (symbol)
  58               && ('-' == scm_i_symbol_chars(symbol)[0]),
  59               symbol, SCM_ARG1, FUNC_NAME);
  60
  61   SCM_DEFER_INTS;
  62   keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F);
  63   if (scm_is_false (keyword))
  64     {
  65       SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
  66       scm_hashq_set_x (scm_keyword_obarray, symbol, keyword);
  67     }
  68   SCM_ALLOW_INTS;
  69   return keyword;
  70 }
  71 #undef FUNC_NAME
  72
  73 SCM
  74 scm_c_make_keyword (char *s)
  75 {
  76   char *buf;
  77   size_t len;
  78   SCM string, symbol;
  79
  80   len = strlen (s) + 1;
  81   string = scm_i_make_string (len, &buf);
  82   buf[0] = '-';
  83   strcpy (buf + 1, s);
  84   symbol = scm_string_to_symbol (string);
  85   return scm_make_keyword_from_dash_symbol (symbol);
  86 }
  87
  88 SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
  89             (SCM obj),
  90             "Return @code{#t} if the argument @var{obj} is a keyword, else\n"
  91             "@code{#f}.")
  92 #define FUNC_NAME s_scm_keyword_p
  93 {
  94   return scm_from_bool (SCM_KEYWORDP (obj));
  95 }
  96 #undef FUNC_NAME
  97
  98
  99 SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
 100             (SCM keyword),
 101             "Return the dash symbol for @var{keyword}.\n"
 102             "This is the inverse of @code{make-keyword-from-dash-symbol}.")
 103 #define FUNC_NAME s_scm_keyword_dash_symbol
 104 {
 105   SCM_VALIDATE_KEYWORD (1, keyword);
 106   return SCM_KEYWORDSYM (keyword);
 107 }
 108 #undef FUNC_NAME
 109
 110
 111
 112 void
 113 scm_init_keywords ()
 114 {
 115   scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
 116   scm_set_smob_mark (scm_tc16_keyword, scm_markcdr);
 117   scm_set_smob_print (scm_tc16_keyword, keyword_print);
 118
 119   scm_keyword_obarray = scm_c_make_hash_table (0);
 120 #include "libguile/keywords.x"
 121 }
 122
 123
 124 /*
 125   Local Variables:
 126   c-file-style: "gnu"
 127   End:
 128 */