keywords.c 5.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203
  1. /* Copyright 1995-2001,2003-2004,2006,2008-2009,2011,2013,2015,2018
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <string.h>
  19. #include <stdarg.h>
  20. #include "async.h"
  21. #include "dynwind.h"
  22. #include "gsubr.h"
  23. #include "hashtab.h"
  24. #include "list.h"
  25. #include "pairs.h"
  26. #include "ports.h"
  27. #include "smob.h"
  28. #include "strings.h"
  29. #include "symbols.h"
  30. #include "keywords.h"
  31. static SCM keyword_obarray;
  32. #define SCM_KEYWORDP(x) (SCM_HAS_TYP7 (x, scm_tc7_keyword))
  33. #define SCM_KEYWORD_SYMBOL(x) (SCM_CELL_OBJECT_1 (x))
  34. SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
  35. (SCM obj),
  36. "Return @code{#t} if the argument @var{obj} is a keyword, else\n"
  37. "@code{#f}.")
  38. #define FUNC_NAME s_scm_keyword_p
  39. {
  40. return scm_from_bool (SCM_KEYWORDP (obj));
  41. }
  42. #undef FUNC_NAME
  43. SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0,
  44. (SCM symbol),
  45. "Return the keyword with the same name as @var{symbol}.")
  46. #define FUNC_NAME s_scm_symbol_to_keyword
  47. {
  48. SCM keyword;
  49. SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol");
  50. scm_dynwind_begin (0);
  51. scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
  52. /* Note: `scm_cell' and `scm_hashq_set_x' can raise an out-of-memory
  53. error. */
  54. keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F);
  55. if (scm_is_false (keyword))
  56. {
  57. keyword = scm_cell (scm_tc7_keyword, SCM_UNPACK (symbol));
  58. scm_hashq_set_x (keyword_obarray, symbol, keyword);
  59. }
  60. scm_dynwind_end ();
  61. return keyword;
  62. }
  63. #undef FUNC_NAME
  64. SCM_DEFINE (scm_keyword_to_symbol, "keyword->symbol", 1, 0, 0,
  65. (SCM keyword),
  66. "Return the symbol with the same name as @var{keyword}.")
  67. #define FUNC_NAME s_scm_keyword_to_symbol
  68. {
  69. SCM_VALIDATE_KEYWORD (1, keyword);
  70. return SCM_KEYWORD_SYMBOL (keyword);
  71. }
  72. #undef FUNC_NAME
  73. int
  74. scm_is_keyword (SCM val)
  75. {
  76. return SCM_KEYWORDP (val);
  77. }
  78. SCM
  79. scm_from_locale_keyword (const char *name)
  80. {
  81. return scm_symbol_to_keyword (scm_from_locale_symbol (name));
  82. }
  83. SCM
  84. scm_from_locale_keywordn (const char *name, size_t len)
  85. {
  86. return scm_symbol_to_keyword (scm_from_locale_symboln (name, len));
  87. }
  88. SCM
  89. scm_from_latin1_keyword (const char *name)
  90. {
  91. return scm_symbol_to_keyword (scm_from_latin1_symbol (name));
  92. }
  93. SCM
  94. scm_from_utf8_keyword (const char *name)
  95. {
  96. return scm_symbol_to_keyword (scm_from_utf8_symbol (name));
  97. }
  98. SCM_SYMBOL (scm_keyword_argument_error, "keyword-argument-error");
  99. void
  100. scm_c_bind_keyword_arguments (const char *subr, SCM rest,
  101. scm_t_keyword_arguments_flags flags, ...)
  102. {
  103. va_list va;
  104. while (scm_is_pair (rest))
  105. {
  106. SCM kw_or_arg = SCM_CAR (rest);
  107. SCM tail = SCM_CDR (rest);
  108. if (scm_is_keyword (kw_or_arg))
  109. {
  110. SCM kw;
  111. SCM *arg_p;
  112. va_start (va, flags);
  113. for (;;)
  114. {
  115. kw = va_arg (va, SCM);
  116. if (SCM_UNBNDP (kw))
  117. {
  118. /* KW_OR_ARG is not in the list of expected keywords. */
  119. if (!(flags & SCM_ALLOW_OTHER_KEYS))
  120. scm_error_scm (scm_keyword_argument_error,
  121. scm_from_locale_string (subr),
  122. scm_from_latin1_string
  123. ("Unrecognized keyword"),
  124. SCM_EOL, scm_list_1 (kw_or_arg));
  125. /* Advance REST. Advance past the argument of an
  126. unrecognized keyword, but don't error if such a
  127. keyword has no argument. */
  128. rest = scm_is_pair (tail) ? SCM_CDR (tail) : tail;
  129. break;
  130. }
  131. arg_p = va_arg (va, SCM *);
  132. if (scm_is_eq (kw_or_arg, kw))
  133. {
  134. /* We found the matching keyword. Store the
  135. associated value and break out of the loop. */
  136. if (!scm_is_pair (tail))
  137. scm_error_scm (scm_keyword_argument_error,
  138. scm_from_locale_string (subr),
  139. scm_from_latin1_string
  140. ("Keyword argument has no value"),
  141. SCM_EOL, scm_list_1 (kw));
  142. *arg_p = SCM_CAR (tail);
  143. /* Advance REST. */
  144. rest = SCM_CDR (tail);
  145. break;
  146. }
  147. }
  148. va_end (va);
  149. }
  150. else
  151. {
  152. /* The next argument is not a keyword, or is a singleton
  153. keyword at the end of REST. */
  154. if (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS))
  155. scm_error_scm (scm_keyword_argument_error,
  156. scm_from_locale_string (subr),
  157. scm_from_latin1_string ("Invalid keyword"),
  158. SCM_EOL, scm_list_1 (kw_or_arg));
  159. /* Advance REST. */
  160. rest = tail;
  161. }
  162. }
  163. }
  164. void
  165. scm_init_keywords ()
  166. {
  167. keyword_obarray = scm_c_make_hash_table (0);
  168. #include "keywords.x"
  169. }