Commit | Line | Data |
---|---|---|
fb3a1121 MW |
1 | /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2006, |
2 | * 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. | |
575888bd | 3 | * |
73be1d9e | 4 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
5 | * modify it under the terms of the GNU Lesser General Public License |
6 | * as published by the Free Software Foundation; either version 3 of | |
7 | * the License, or (at your option) any later version. | |
575888bd | 8 | * |
53befeb7 NJ |
9 | * This library is distributed in the hope that it will be useful, but |
10 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | * Lesser General Public License for more details. | |
575888bd | 13 | * |
73be1d9e MV |
14 | * You should have received a copy of the GNU Lesser General Public |
15 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
17 | * 02110-1301 USA | |
73be1d9e | 18 | */ |
1bbd0b84 | 19 | |
1bbd0b84 | 20 | |
575888bd | 21 | \f |
dbb605f5 LC |
22 | #ifdef HAVE_CONFIG_H |
23 | # include <config.h> | |
24 | #endif | |
575888bd | 25 | |
e6e2e95a MD |
26 | #include <errno.h> |
27 | ||
a0599745 | 28 | #include "libguile/_scm.h" |
4e047c3e | 29 | #include "libguile/async.h" |
a0599745 MD |
30 | #include "libguile/smob.h" |
31 | #include "libguile/alist.h" | |
32 | #include "libguile/debug.h" | |
33 | #include "libguile/hashtab.h" | |
34 | #include "libguile/hash.h" | |
35 | #include "libguile/ports.h" | |
36 | #include "libguile/root.h" | |
37 | #include "libguile/weaks.h" | |
42e6668b | 38 | #include "libguile/gc.h" |
575888bd | 39 | |
a0599745 MD |
40 | #include "libguile/validate.h" |
41 | #include "libguile/srcprop.h" | |
26c8cc14 AW |
42 | #include "libguile/private-options.h" |
43 | ||
575888bd MD |
44 | \f |
45 | /* {Source Properties} | |
46 | * | |
47 | * Properties of source list expressions. | |
8cbcaaa0 | 48 | * Four of these have special meaning: |
575888bd MD |
49 | * |
50 | * filename string The name of the source file. | |
51 | * copy list A copy of the list expression. | |
52 | * line integer The source code line number. | |
53 | * column integer The source code column number. | |
575888bd MD |
54 | * |
55 | * Most properties above can be set by the reader. | |
56 | * | |
57 | */ | |
58 | ||
85db4a2c DH |
59 | SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); |
60 | SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy"); | |
61 | SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); | |
62 | SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); | |
575888bd | 63 | |
2f045fc1 AW |
64 | static SCM scm_source_whash; |
65 | static scm_i_pthread_mutex_t source_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; | |
575888bd | 66 | |
1cc91f1b | 67 | |
b0763985 | 68 | /* |
d00a0704 HWN |
69 | * Source properties are stored as double cells with the |
70 | * following layout: | |
b0763985 | 71 | |
d00a0704 HWN |
72 | * car = tag |
73 | * cbr = pos | |
74 | * ccr = copy | |
d5ed380e | 75 | * cdr = alist |
d00a0704 | 76 | */ |
b0763985 HWN |
77 | |
78 | #define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p))) | |
9e9e54eb | 79 | #define SRCPROPPOS(p) (SCM_SMOB_DATA(p)) |
b0763985 HWN |
80 | #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) |
81 | #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) | |
9e9e54eb AW |
82 | #define SRCPROPCOPY(p) (SCM_SMOB_OBJECT_2(p)) |
83 | #define SRCPROPALIST(p) (SCM_SMOB_OBJECT_3(p)) | |
b0763985 | 84 | #define SRCPROPMAKPOS(l, c) (((l) << 12) + (c)) |
9e9e54eb | 85 | #define SETSRCPROPPOS(p, l, c) (SCM_SET_SMOB_DATA_1 (p, SRCPROPMAKPOS (l, c))) |
b0763985 HWN |
86 | #define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) |
87 | #define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) | |
9e9e54eb AW |
88 | #define SETSRCPROPCOPY(p, c) (SCM_SET_SMOB_OBJECT_2 (p, c)) |
89 | #define SETSRCPROPALIST(p, l) (SCM_SET_SMOB_OBJECT_3 (p, l)) | |
b0763985 HWN |
90 | |
91 | ||
67a96734 NJ |
92 | static SCM scm_srcprops_to_alist (SCM obj); |
93 | ||
b0763985 | 94 | |
92c2555f | 95 | scm_t_bits scm_tc16_srcprops; |
575888bd | 96 | |
76b9bac5 MW |
97 | |
98 | static int | |
99 | supports_source_props (SCM obj) | |
100 | { | |
101 | return SCM_NIMP (obj) && !scm_is_symbol (obj) && !scm_is_keyword (obj); | |
102 | } | |
103 | ||
104 | ||
575888bd | 105 | static int |
e841c3e0 | 106 | srcprops_print (SCM obj, SCM port, scm_print_state *pstate) |
575888bd | 107 | { |
19402679 | 108 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 109 | scm_puts ("#<srcprops ", port); |
19402679 | 110 | SCM_SET_WRITINGP (pstate, 1); |
67a96734 | 111 | scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate); |
19402679 | 112 | SCM_SET_WRITINGP (pstate, writingp); |
b7f3516f | 113 | scm_putc ('>', port); |
575888bd MD |
114 | return 1; |
115 | } | |
116 | ||
1cc91f1b | 117 | |
b0763985 | 118 | /* |
67a96734 | 119 | * We remember the last file name settings, so we can share that alist |
d00a0704 | 120 | * entry. This works because scm_set_source_property_x does not use |
67a96734 | 121 | * assoc-set! for modifying the alist. |
d00a0704 HWN |
122 | * |
123 | * This variable contains a protected cons, whose cdr is the cached | |
67a96734 | 124 | * alist |
b0763985 | 125 | */ |
67a96734 | 126 | static SCM scm_last_alist_filename; |
b0763985 | 127 | |
575888bd | 128 | SCM |
67a96734 | 129 | scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist) |
575888bd | 130 | { |
b0763985 | 131 | if (!SCM_UNBNDP (filename)) |
575888bd | 132 | { |
67a96734 | 133 | SCM old_alist = alist; |
42e6668b | 134 | |
b0763985 HWN |
135 | /* |
136 | have to extract the acons, and operate on that, for | |
137 | thread safety. | |
138 | */ | |
67a96734 | 139 | SCM last_acons = SCM_CDR (scm_last_alist_filename); |
393baa8a AW |
140 | if (scm_is_null (old_alist) |
141 | && scm_is_eq (SCM_CDAR (last_acons), filename)) | |
b0763985 | 142 | { |
67a96734 | 143 | alist = last_acons; |
b0763985 HWN |
144 | } |
145 | else | |
146 | { | |
67a96734 | 147 | alist = scm_acons (scm_sym_filename, filename, alist); |
393baa8a | 148 | if (scm_is_null (old_alist)) |
67a96734 | 149 | SCM_SETCDR (scm_last_alist_filename, alist); |
b0763985 | 150 | } |
575888bd | 151 | } |
b0763985 HWN |
152 | |
153 | SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops, | |
154 | SRCPROPMAKPOS (line, col), | |
b2b33168 AW |
155 | SCM_UNPACK (copy), |
156 | SCM_UNPACK (alist)); | |
575888bd MD |
157 | } |
158 | ||
1cc91f1b | 159 | |
67a96734 NJ |
160 | static SCM |
161 | scm_srcprops_to_alist (SCM obj) | |
575888bd | 162 | { |
67a96734 | 163 | SCM alist = SRCPROPALIST (obj); |
575888bd | 164 | if (!SCM_UNBNDP (SRCPROPCOPY (obj))) |
67a96734 NJ |
165 | alist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), alist); |
166 | alist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), alist); | |
167 | alist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), alist); | |
67a96734 | 168 | return alist; |
575888bd MD |
169 | } |
170 | ||
76b9bac5 MW |
171 | SCM_DEFINE (scm_supports_source_properties_p, "supports-source-properties?", 1, 0, 0, |
172 | (SCM obj), | |
173 | "Return #t if @var{obj} supports adding source properties,\n" | |
174 | "otherwise return #f.") | |
175 | #define FUNC_NAME s_scm_supports_source_properties_p | |
176 | { | |
177 | return scm_from_bool (supports_source_props (obj)); | |
178 | } | |
179 | #undef FUNC_NAME | |
180 | ||
a1ec6916 | 181 | SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, |
1bbd0b84 | 182 | (SCM obj), |
e3239868 | 183 | "Return the source property association list of @var{obj}.") |
1bbd0b84 | 184 | #define FUNC_NAME s_scm_source_properties |
575888bd | 185 | { |
fb3a1121 MW |
186 | if (SCM_IMP (obj)) |
187 | return SCM_EOL; | |
188 | else | |
189 | { | |
190 | SCM p; | |
2f045fc1 | 191 | |
fb3a1121 MW |
192 | scm_i_pthread_mutex_lock (&source_lock); |
193 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); | |
194 | scm_i_pthread_mutex_unlock (&source_lock); | |
2f045fc1 | 195 | |
fb3a1121 MW |
196 | if (SRCPROPSP (p)) |
197 | return scm_srcprops_to_alist (p); | |
198 | else | |
199 | /* list from set-source-properties!, or SCM_EOL for not found */ | |
200 | return p; | |
201 | } | |
575888bd | 202 | } |
1bbd0b84 | 203 | #undef FUNC_NAME |
575888bd MD |
204 | |
205 | /* Perhaps this procedure should look through an alist | |
206 | and try to make a srcprops-object...? */ | |
a1ec6916 | 207 | SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, |
67a96734 NJ |
208 | (SCM obj, SCM alist), |
209 | "Install the association list @var{alist} as the source property\n" | |
e3239868 | 210 | "list for @var{obj}.") |
1bbd0b84 | 211 | #define FUNC_NAME s_scm_set_source_properties_x |
575888bd | 212 | { |
34d19ef6 | 213 | SCM_VALIDATE_NIM (1, obj); |
2f045fc1 AW |
214 | |
215 | scm_i_pthread_mutex_lock (&source_lock); | |
d1c4720c | 216 | scm_hashq_set_x (scm_source_whash, obj, alist); |
2f045fc1 AW |
217 | scm_i_pthread_mutex_unlock (&source_lock); |
218 | ||
67a96734 | 219 | return alist; |
575888bd | 220 | } |
1bbd0b84 | 221 | #undef FUNC_NAME |
575888bd | 222 | |
26c8cc14 AW |
223 | int |
224 | scm_i_has_source_properties (SCM obj) | |
225 | #define FUNC_NAME "%set-source-properties" | |
226 | { | |
fb3a1121 MW |
227 | if (SCM_IMP (obj)) |
228 | return 0; | |
229 | else | |
230 | { | |
231 | int ret; | |
26c8cc14 | 232 | |
fb3a1121 MW |
233 | scm_i_pthread_mutex_lock (&source_lock); |
234 | ret = scm_is_true (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F)); | |
235 | scm_i_pthread_mutex_unlock (&source_lock); | |
2f045fc1 | 236 | |
fb3a1121 MW |
237 | return ret; |
238 | } | |
26c8cc14 AW |
239 | } |
240 | #undef FUNC_NAME | |
241 | ||
242 | ||
243 | void | |
244 | scm_i_set_source_properties_x (SCM obj, long line, int col, SCM fname) | |
245 | #define FUNC_NAME "%set-source-properties" | |
246 | { | |
247 | SCM_VALIDATE_NIM (1, obj); | |
248 | ||
2f045fc1 | 249 | scm_i_pthread_mutex_lock (&source_lock); |
26c8cc14 AW |
250 | scm_hashq_set_x (scm_source_whash, obj, |
251 | scm_make_srcprops (line, col, fname, | |
252 | SCM_COPY_SOURCE_P | |
253 | ? scm_copy_tree (obj) | |
254 | : SCM_UNDEFINED, | |
255 | SCM_EOL)); | |
2f045fc1 | 256 | scm_i_pthread_mutex_unlock (&source_lock); |
26c8cc14 AW |
257 | } |
258 | #undef FUNC_NAME | |
259 | ||
a1ec6916 | 260 | SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, |
1bbd0b84 | 261 | (SCM obj, SCM key), |
e3239868 DH |
262 | "Return the source property specified by @var{key} from\n" |
263 | "@var{obj}'s source property list.") | |
1bbd0b84 | 264 | #define FUNC_NAME s_scm_source_property |
575888bd | 265 | { |
fb3a1121 MW |
266 | if (SCM_IMP (obj)) |
267 | return SCM_BOOL_F; | |
575888bd MD |
268 | else |
269 | { | |
fb3a1121 MW |
270 | SCM p; |
271 | ||
272 | scm_i_pthread_mutex_lock (&source_lock); | |
273 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); | |
274 | scm_i_pthread_mutex_unlock (&source_lock); | |
275 | ||
276 | if (!SRCPROPSP (p)) | |
277 | goto alist; | |
278 | if (scm_is_eq (scm_sym_line, key)) | |
279 | p = scm_from_int (SRCPROPLINE (p)); | |
280 | else if (scm_is_eq (scm_sym_column, key)) | |
281 | p = scm_from_int (SRCPROPCOL (p)); | |
282 | else if (scm_is_eq (scm_sym_copy, key)) | |
283 | p = SRCPROPCOPY (p); | |
284 | else | |
285 | { | |
286 | p = SRCPROPALIST (p); | |
287 | alist: | |
288 | p = scm_assoc (key, p); | |
289 | return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); | |
290 | } | |
291 | return SCM_UNBNDP (p) ? SCM_BOOL_F : p; | |
575888bd | 292 | } |
575888bd | 293 | } |
1bbd0b84 | 294 | #undef FUNC_NAME |
575888bd | 295 | |
a1ec6916 | 296 | SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, |
1bbd0b84 | 297 | (SCM obj, SCM key, SCM datum), |
e3239868 DH |
298 | "Set the source property of object @var{obj}, which is specified by\n" |
299 | "@var{key} to @var{datum}. Normally, the key will be a symbol.") | |
1bbd0b84 | 300 | #define FUNC_NAME s_scm_set_source_property_x |
575888bd | 301 | { |
575888bd | 302 | SCM p; |
34d19ef6 | 303 | SCM_VALIDATE_NIM (1, obj); |
2f045fc1 AW |
304 | |
305 | scm_i_pthread_mutex_lock (&source_lock); | |
d1c4720c | 306 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); |
8cbcaaa0 AW |
307 | |
308 | if (scm_is_eq (scm_sym_line, key)) | |
575888bd | 309 | { |
0c95b57d | 310 | if (SRCPROPSP (p)) |
a55c2b68 | 311 | SETSRCPROPLINE (p, scm_to_int (datum)); |
575888bd | 312 | else |
d1c4720c AW |
313 | scm_hashq_set_x (scm_source_whash, obj, |
314 | scm_make_srcprops (scm_to_int (datum), 0, | |
315 | SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
575888bd | 316 | } |
bc36d050 | 317 | else if (scm_is_eq (scm_sym_column, key)) |
575888bd | 318 | { |
0c95b57d | 319 | if (SRCPROPSP (p)) |
a55c2b68 | 320 | SETSRCPROPCOL (p, scm_to_int (datum)); |
575888bd | 321 | else |
d1c4720c AW |
322 | scm_hashq_set_x (scm_source_whash, obj, |
323 | scm_make_srcprops (0, scm_to_int (datum), | |
324 | SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
575888bd | 325 | } |
bc36d050 | 326 | else if (scm_is_eq (scm_sym_copy, key)) |
575888bd | 327 | { |
0c95b57d | 328 | if (SRCPROPSP (p)) |
80237dcc | 329 | SETSRCPROPCOPY (p, datum); |
575888bd | 330 | else |
d1c4720c AW |
331 | scm_hashq_set_x (scm_source_whash, obj, |
332 | scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); | |
575888bd MD |
333 | } |
334 | else | |
58d233cc NJ |
335 | { |
336 | if (SRCPROPSP (p)) | |
67a96734 | 337 | SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p))); |
58d233cc | 338 | else |
d1c4720c AW |
339 | scm_hashq_set_x (scm_source_whash, obj, |
340 | scm_acons (key, datum, p)); | |
58d233cc | 341 | } |
2f045fc1 AW |
342 | scm_i_pthread_mutex_unlock (&source_lock); |
343 | ||
575888bd MD |
344 | return SCM_UNSPECIFIED; |
345 | } | |
1bbd0b84 | 346 | #undef FUNC_NAME |
575888bd | 347 | |
1cc91f1b | 348 | |
0f458a37 AW |
349 | SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, |
350 | (SCM xorig, SCM x, SCM y), | |
351 | "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n" | |
352 | "Any source properties associated with @var{xorig} are also associated\n" | |
353 | "with the new pair.") | |
354 | #define FUNC_NAME s_scm_cons_source | |
355 | { | |
356 | SCM p, z; | |
357 | z = scm_cons (x, y); | |
2f045fc1 | 358 | scm_i_pthread_mutex_lock (&source_lock); |
0f458a37 | 359 | /* Copy source properties possibly associated with xorig. */ |
d1c4720c | 360 | p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F); |
0f458a37 | 361 | if (scm_is_true (p)) |
d1c4720c | 362 | scm_hashq_set_x (scm_source_whash, z, p); |
2f045fc1 | 363 | scm_i_pthread_mutex_unlock (&source_lock); |
0f458a37 AW |
364 | return z; |
365 | } | |
366 | #undef FUNC_NAME | |
367 | ||
368 | ||
575888bd MD |
369 | void |
370 | scm_init_srcprop () | |
575888bd | 371 | { |
e841c3e0 | 372 | scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0); |
e841c3e0 KN |
373 | scm_set_smob_print (scm_tc16_srcprops, srcprops_print); |
374 | ||
e11e83f3 | 375 | scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047)); |
86d31dfe | 376 | scm_c_define ("source-whash", scm_source_whash); |
85db4a2c | 377 | |
f39448c5 AW |
378 | scm_last_alist_filename = scm_cons (SCM_EOL, |
379 | scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)); | |
b0763985 | 380 | |
a0599745 | 381 | #include "libguile/srcprop.x" |
575888bd MD |
382 | } |
383 | ||
89e00824 ML |
384 | |
385 | /* | |
386 | Local Variables: | |
387 | c-file-style: "gnu" | |
388 | End: | |
389 | */ |