Commit | Line | Data |
---|---|---|
2b829bbb | 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006 Free Software Foundation |
575888bd | 2 | * |
73be1d9e MV |
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. | |
575888bd | 7 | * |
73be1d9e MV |
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. | |
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 | |
92205699 | 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 16 | */ |
1bbd0b84 | 17 | |
1bbd0b84 | 18 | |
575888bd MD |
19 | \f |
20 | ||
e6e2e95a MD |
21 | #include <errno.h> |
22 | ||
a0599745 | 23 | #include "libguile/_scm.h" |
4e047c3e | 24 | #include "libguile/async.h" |
a0599745 MD |
25 | #include "libguile/smob.h" |
26 | #include "libguile/alist.h" | |
27 | #include "libguile/debug.h" | |
28 | #include "libguile/hashtab.h" | |
29 | #include "libguile/hash.h" | |
30 | #include "libguile/ports.h" | |
31 | #include "libguile/root.h" | |
32 | #include "libguile/weaks.h" | |
575888bd | 33 | |
a0599745 MD |
34 | #include "libguile/validate.h" |
35 | #include "libguile/srcprop.h" | |
575888bd MD |
36 | \f |
37 | /* {Source Properties} | |
38 | * | |
39 | * Properties of source list expressions. | |
b0763985 | 40 | * Five of these have special meaning: |
575888bd MD |
41 | * |
42 | * filename string The name of the source file. | |
43 | * copy list A copy of the list expression. | |
44 | * line integer The source code line number. | |
45 | * column integer The source code column number. | |
46 | * breakpoint boolean Sets a breakpoint on this form. | |
47 | * | |
48 | * Most properties above can be set by the reader. | |
49 | * | |
50 | */ | |
51 | ||
85db4a2c DH |
52 | SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); |
53 | SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy"); | |
54 | SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); | |
55 | SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); | |
56 | SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); | |
575888bd | 57 | |
575888bd | 58 | |
1cc91f1b | 59 | |
b0763985 | 60 | /* |
d00a0704 HWN |
61 | * Source properties are stored as double cells with the |
62 | * following layout: | |
b0763985 | 63 | |
d00a0704 HWN |
64 | * car = tag |
65 | * cbr = pos | |
66 | * ccr = copy | |
67 | * cdr = plist | |
68 | */ | |
b0763985 HWN |
69 | |
70 | #define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p))) | |
71 | #define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK) | |
72 | #define SRCPROPPOS(p) (SCM_CELL_WORD(p,1)) | |
73 | #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) | |
74 | #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) | |
75 | #define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2)) | |
76 | #define SRCPROPPLIST(p) (SCM_CELL_OBJECT_3(p)) | |
77 | #define SETSRCPROPBRK(p) \ | |
78 | (SCM_SET_SMOB_FLAGS ((p), \ | |
79 | SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK)) | |
80 | #define CLEARSRCPROPBRK(p) \ | |
81 | (SCM_SET_SMOB_FLAGS ((p), \ | |
82 | SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK)) | |
83 | #define SRCPROPMAKPOS(l, c) (((l) << 12) + (c)) | |
84 | #define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c))) | |
85 | #define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) | |
86 | #define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) | |
87 | ||
88 | ||
89 | ||
90 | scm_t_bits scm_tc16_srcprops; | |
91 | ||
575888bd | 92 | static SCM |
e841c3e0 | 93 | srcprops_mark (SCM obj) |
575888bd | 94 | { |
575888bd MD |
95 | scm_gc_mark (SRCPROPCOPY (obj)); |
96 | return SRCPROPPLIST (obj); | |
97 | } | |
98 | ||
575888bd | 99 | static int |
e841c3e0 | 100 | srcprops_print (SCM obj, SCM port, scm_print_state *pstate) |
575888bd | 101 | { |
19402679 | 102 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 103 | scm_puts ("#<srcprops ", port); |
19402679 | 104 | SCM_SET_WRITINGP (pstate, 1); |
7862b07e | 105 | scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate); |
19402679 | 106 | SCM_SET_WRITINGP (pstate, writingp); |
b7f3516f | 107 | scm_putc ('>', port); |
575888bd MD |
108 | return 1; |
109 | } | |
110 | ||
1cc91f1b | 111 | |
bc76d628 DH |
112 | int |
113 | scm_c_source_property_breakpoint_p (SCM form) | |
114 | { | |
115 | SCM obj = scm_whash_lookup (scm_source_whash, form); | |
116 | return SRCPROPSP (obj) && SRCPROPBRK (obj); | |
117 | } | |
118 | ||
119 | ||
b0763985 | 120 | /* |
d00a0704 HWN |
121 | * We remember the last file name settings, so we can share that plist |
122 | * entry. This works because scm_set_source_property_x does not use | |
123 | * assoc-set! for modifying the plist. | |
124 | * | |
125 | * This variable contains a protected cons, whose cdr is the cached | |
126 | * plist | |
b0763985 HWN |
127 | */ |
128 | static SCM scm_last_plist_filename; | |
129 | ||
575888bd | 130 | SCM |
1be6b49c | 131 | scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) |
575888bd | 132 | { |
b0763985 | 133 | if (!SCM_UNBNDP (filename)) |
575888bd | 134 | { |
b0763985 HWN |
135 | SCM old_plist = plist; |
136 | ||
137 | /* | |
138 | have to extract the acons, and operate on that, for | |
139 | thread safety. | |
140 | */ | |
141 | SCM last_acons = SCM_CDR (scm_last_plist_filename); | |
142 | if (old_plist == SCM_EOL | |
143 | && SCM_CDAR (last_acons) == filename) | |
144 | { | |
145 | plist = last_acons; | |
146 | } | |
147 | else | |
148 | { | |
149 | plist = scm_acons (scm_sym_filename, filename, plist); | |
150 | if (old_plist == SCM_EOL) | |
151 | SCM_SETCDR (scm_last_plist_filename, plist); | |
152 | } | |
575888bd | 153 | } |
b0763985 HWN |
154 | |
155 | SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops, | |
156 | SRCPROPMAKPOS (line, col), | |
157 | copy, | |
158 | plist); | |
575888bd MD |
159 | } |
160 | ||
1cc91f1b | 161 | |
575888bd | 162 | SCM |
7862b07e | 163 | scm_srcprops_to_plist (SCM obj) |
575888bd MD |
164 | { |
165 | SCM plist = SRCPROPPLIST (obj); | |
166 | if (!SCM_UNBNDP (SRCPROPCOPY (obj))) | |
92e5aa0e | 167 | plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist); |
e11e83f3 MV |
168 | plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist); |
169 | plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist); | |
7888309b | 170 | plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist); |
575888bd MD |
171 | return plist; |
172 | } | |
173 | ||
a1ec6916 | 174 | SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, |
1bbd0b84 | 175 | (SCM obj), |
e3239868 | 176 | "Return the source property association list of @var{obj}.") |
1bbd0b84 | 177 | #define FUNC_NAME s_scm_source_properties |
575888bd MD |
178 | { |
179 | SCM p; | |
34d19ef6 | 180 | SCM_VALIDATE_NIM (1, obj); |
575888bd | 181 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 | 182 | obj = SCM_MEMOIZED_EXP (obj); |
d2e53ed6 | 183 | else if (!scm_is_pair (obj)) |
1bbd0b84 | 184 | SCM_WRONG_TYPE_ARG (1, obj); |
f5003c13 | 185 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); |
230d095f | 186 | if (SRCPROPSP (p)) |
7862b07e | 187 | return scm_srcprops_to_plist (p); |
f5003c13 KR |
188 | else |
189 | /* list from set-source-properties!, or SCM_EOL for not found */ | |
190 | return p; | |
575888bd | 191 | } |
1bbd0b84 | 192 | #undef FUNC_NAME |
575888bd MD |
193 | |
194 | /* Perhaps this procedure should look through an alist | |
195 | and try to make a srcprops-object...? */ | |
a1ec6916 | 196 | SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, |
1bbd0b84 | 197 | (SCM obj, SCM plist), |
e3239868 DH |
198 | "Install the association list @var{plist} as the source property\n" |
199 | "list for @var{obj}.") | |
1bbd0b84 | 200 | #define FUNC_NAME s_scm_set_source_properties_x |
575888bd MD |
201 | { |
202 | SCM handle; | |
34d19ef6 | 203 | SCM_VALIDATE_NIM (1, obj); |
575888bd | 204 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 | 205 | obj = SCM_MEMOIZED_EXP (obj); |
d2e53ed6 | 206 | else if (!scm_is_pair (obj)) |
1bbd0b84 | 207 | SCM_WRONG_TYPE_ARG(1, obj); |
575888bd MD |
208 | handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); |
209 | SCM_SETCDR (handle, plist); | |
210 | return plist; | |
211 | } | |
1bbd0b84 | 212 | #undef FUNC_NAME |
575888bd | 213 | |
a1ec6916 | 214 | SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, |
1bbd0b84 | 215 | (SCM obj, SCM key), |
e3239868 DH |
216 | "Return the source property specified by @var{key} from\n" |
217 | "@var{obj}'s source property list.") | |
1bbd0b84 | 218 | #define FUNC_NAME s_scm_source_property |
575888bd MD |
219 | { |
220 | SCM p; | |
34d19ef6 | 221 | SCM_VALIDATE_NIM (1, obj); |
575888bd | 222 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 | 223 | obj = SCM_MEMOIZED_EXP (obj); |
d2e53ed6 | 224 | else if (!scm_is_pair (obj)) |
1bbd0b84 | 225 | SCM_WRONG_TYPE_ARG (1, obj); |
575888bd | 226 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); |
24933780 | 227 | if (!SRCPROPSP (p)) |
575888bd | 228 | goto plist; |
bc36d050 MV |
229 | if (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p)); |
230 | else if (scm_is_eq (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p)); | |
231 | else if (scm_is_eq (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p)); | |
bc36d050 | 232 | else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p); |
575888bd MD |
233 | else |
234 | { | |
235 | p = SRCPROPPLIST (p); | |
236 | plist: | |
237 | p = scm_assoc (key, p); | |
238 | return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); | |
239 | } | |
240 | return SCM_UNBNDP (p) ? SCM_BOOL_F : p; | |
241 | } | |
1bbd0b84 | 242 | #undef FUNC_NAME |
575888bd | 243 | |
a1ec6916 | 244 | SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, |
1bbd0b84 | 245 | (SCM obj, SCM key, SCM datum), |
e3239868 DH |
246 | "Set the source property of object @var{obj}, which is specified by\n" |
247 | "@var{key} to @var{datum}. Normally, the key will be a symbol.") | |
1bbd0b84 | 248 | #define FUNC_NAME s_scm_set_source_property_x |
575888bd MD |
249 | { |
250 | scm_whash_handle h; | |
251 | SCM p; | |
34d19ef6 | 252 | SCM_VALIDATE_NIM (1, obj); |
575888bd | 253 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 | 254 | obj = SCM_MEMOIZED_EXP (obj); |
d2e53ed6 | 255 | else if (!scm_is_pair (obj)) |
1bbd0b84 | 256 | SCM_WRONG_TYPE_ARG (1, obj); |
575888bd MD |
257 | h = scm_whash_get_handle (scm_source_whash, obj); |
258 | if (SCM_WHASHFOUNDP (h)) | |
259 | p = SCM_WHASHREF (scm_source_whash, h); | |
260 | else | |
261 | { | |
262 | h = scm_whash_create_handle (scm_source_whash, obj); | |
263 | p = SCM_EOL; | |
264 | } | |
bc36d050 | 265 | if (scm_is_eq (scm_sym_breakpoint, key)) |
cda139a7 | 266 | { |
62850ef3 DH |
267 | if (SRCPROPSP (p)) |
268 | { | |
7888309b | 269 | if (scm_is_false (datum)) |
62850ef3 DH |
270 | CLEARSRCPROPBRK (p); |
271 | else | |
272 | SETSRCPROPBRK (p); | |
273 | } | |
cda139a7 | 274 | else |
62850ef3 DH |
275 | { |
276 | SCM sp = scm_make_srcprops (0, 0, SCM_UNDEFINED, SCM_UNDEFINED, p); | |
277 | SCM_WHASHSET (scm_source_whash, h, sp); | |
7888309b | 278 | if (scm_is_false (datum)) |
62850ef3 DH |
279 | CLEARSRCPROPBRK (sp); |
280 | else | |
281 | SETSRCPROPBRK (sp); | |
282 | } | |
cda139a7 | 283 | } |
bc36d050 | 284 | else if (scm_is_eq (scm_sym_line, key)) |
575888bd | 285 | { |
0c95b57d | 286 | if (SRCPROPSP (p)) |
a55c2b68 | 287 | SETSRCPROPLINE (p, scm_to_int (datum)); |
575888bd MD |
288 | else |
289 | SCM_WHASHSET (scm_source_whash, h, | |
a55c2b68 | 290 | scm_make_srcprops (scm_to_int (datum), 0, |
a9dbb9fd | 291 | SCM_UNDEFINED, SCM_UNDEFINED, p)); |
575888bd | 292 | } |
bc36d050 | 293 | else if (scm_is_eq (scm_sym_column, key)) |
575888bd | 294 | { |
0c95b57d | 295 | if (SRCPROPSP (p)) |
a55c2b68 | 296 | SETSRCPROPCOL (p, scm_to_int (datum)); |
575888bd MD |
297 | else |
298 | SCM_WHASHSET (scm_source_whash, h, | |
a55c2b68 | 299 | scm_make_srcprops (0, scm_to_int (datum), |
a9dbb9fd | 300 | SCM_UNDEFINED, SCM_UNDEFINED, p)); |
575888bd | 301 | } |
bc36d050 | 302 | else if (scm_is_eq (scm_sym_copy, key)) |
575888bd | 303 | { |
0c95b57d | 304 | if (SRCPROPSP (p)) |
575888bd MD |
305 | SRCPROPCOPY (p) = datum; |
306 | else | |
5c5549cb | 307 | SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); |
575888bd MD |
308 | } |
309 | else | |
58d233cc NJ |
310 | { |
311 | if (SRCPROPSP (p)) | |
312 | SRCPROPPLIST (p) = scm_acons (key, datum, SRCPROPPLIST (p)); | |
313 | else | |
314 | SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); | |
315 | } | |
575888bd MD |
316 | return SCM_UNSPECIFIED; |
317 | } | |
1bbd0b84 | 318 | #undef FUNC_NAME |
575888bd | 319 | |
1cc91f1b | 320 | |
575888bd MD |
321 | void |
322 | scm_init_srcprop () | |
575888bd | 323 | { |
e841c3e0 KN |
324 | scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0); |
325 | scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark); | |
e841c3e0 KN |
326 | scm_set_smob_print (scm_tc16_srcprops, srcprops_print); |
327 | ||
e11e83f3 | 328 | scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047)); |
86d31dfe | 329 | scm_c_define ("source-whash", scm_source_whash); |
85db4a2c | 330 | |
b0763985 HWN |
331 | scm_last_plist_filename |
332 | = scm_permanent_object (scm_cons (SCM_EOL, | |
333 | scm_acons (SCM_EOL, SCM_EOL, SCM_EOL))); | |
334 | ||
a0599745 | 335 | #include "libguile/srcprop.x" |
575888bd MD |
336 | } |
337 | ||
89e00824 ML |
338 | |
339 | /* | |
340 | Local Variables: | |
341 | c-file-style: "gnu" | |
342 | End: | |
343 | */ |