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