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