Commit | Line | Data |
---|---|---|
8505e285 | 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 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 | |
15 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
16 | */ | |
1bbd0b84 | 17 | |
1bbd0b84 | 18 | |
575888bd MD |
19 | \f |
20 | ||
e6e2e95a MD |
21 | #include <errno.h> |
22 | ||
a0599745 MD |
23 | #include "libguile/_scm.h" |
24 | #include "libguile/smob.h" | |
25 | #include "libguile/alist.h" | |
26 | #include "libguile/debug.h" | |
27 | #include "libguile/hashtab.h" | |
28 | #include "libguile/hash.h" | |
29 | #include "libguile/ports.h" | |
30 | #include "libguile/root.h" | |
31 | #include "libguile/weaks.h" | |
575888bd | 32 | |
a0599745 MD |
33 | #include "libguile/validate.h" |
34 | #include "libguile/srcprop.h" | |
575888bd MD |
35 | \f |
36 | /* {Source Properties} | |
37 | * | |
38 | * Properties of source list expressions. | |
39 | * Five of these have special meaning and optimized storage: | |
40 | * | |
41 | * filename string The name of the source file. | |
42 | * copy list A copy of the list expression. | |
43 | * line integer The source code line number. | |
44 | * column integer The source code column number. | |
45 | * breakpoint boolean Sets a breakpoint on this form. | |
46 | * | |
47 | * Most properties above can be set by the reader. | |
48 | * | |
49 | */ | |
50 | ||
85db4a2c DH |
51 | SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); |
52 | SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy"); | |
53 | SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); | |
54 | SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); | |
55 | SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); | |
575888bd | 56 | |
92c2555f MV |
57 | scm_t_bits scm_tc16_srcprops; |
58 | static scm_t_srcprops_chunk *srcprops_chunklist = 0; | |
59 | static scm_t_srcprops *srcprops_freelist = 0; | |
575888bd | 60 | |
1cc91f1b | 61 | |
575888bd | 62 | static SCM |
e841c3e0 | 63 | srcprops_mark (SCM obj) |
575888bd | 64 | { |
575888bd MD |
65 | scm_gc_mark (SRCPROPFNAME (obj)); |
66 | scm_gc_mark (SRCPROPCOPY (obj)); | |
67 | return SRCPROPPLIST (obj); | |
68 | } | |
69 | ||
1cc91f1b | 70 | |
1be6b49c | 71 | static size_t |
e841c3e0 | 72 | srcprops_free (SCM obj) |
575888bd | 73 | { |
92c2555f MV |
74 | *((scm_t_srcprops **) SCM_CELL_WORD_1 (obj)) = srcprops_freelist; |
75 | srcprops_freelist = (scm_t_srcprops *) SCM_CELL_WORD_1 (obj); | |
575888bd MD |
76 | return 0; /* srcprops_chunks are not freed until leaving guile */ |
77 | } | |
78 | ||
1cc91f1b | 79 | |
575888bd | 80 | static int |
e841c3e0 | 81 | srcprops_print (SCM obj, SCM port, scm_print_state *pstate) |
575888bd | 82 | { |
19402679 | 83 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 84 | scm_puts ("#<srcprops ", port); |
19402679 | 85 | SCM_SET_WRITINGP (pstate, 1); |
7862b07e | 86 | scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate); |
19402679 | 87 | SCM_SET_WRITINGP (pstate, writingp); |
b7f3516f | 88 | scm_putc ('>', port); |
575888bd MD |
89 | return 1; |
90 | } | |
91 | ||
1cc91f1b | 92 | |
bc76d628 DH |
93 | int |
94 | scm_c_source_property_breakpoint_p (SCM form) | |
95 | { | |
96 | SCM obj = scm_whash_lookup (scm_source_whash, form); | |
97 | return SRCPROPSP (obj) && SRCPROPBRK (obj); | |
98 | } | |
99 | ||
100 | ||
575888bd | 101 | SCM |
1be6b49c | 102 | scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) |
575888bd | 103 | { |
92c2555f | 104 | register scm_t_srcprops *ptr; |
575888bd MD |
105 | SCM_DEFER_INTS; |
106 | if ((ptr = srcprops_freelist) != NULL) | |
92c2555f | 107 | srcprops_freelist = *(scm_t_srcprops **)ptr; |
575888bd MD |
108 | else |
109 | { | |
1be6b49c | 110 | size_t i; |
92c2555f MV |
111 | scm_t_srcprops_chunk *mem; |
112 | size_t n = sizeof (scm_t_srcprops_chunk) | |
113 | + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1); | |
67329a9e | 114 | SCM_SYSCALL (mem = (scm_t_srcprops_chunk *) scm_malloc (n)); |
2500356c DH |
115 | if (mem == NULL) |
116 | scm_memory_error ("srcprops"); | |
0068984b HWN |
117 | scm_gc_register_collectable_memory (mem, n, "srcprops"); |
118 | ||
575888bd MD |
119 | mem->next = srcprops_chunklist; |
120 | srcprops_chunklist = mem; | |
121 | ptr = &mem->srcprops[0]; | |
122 | for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i) | |
92c2555f MV |
123 | *(scm_t_srcprops **)&ptr[i] = &ptr[i + 1]; |
124 | *(scm_t_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; | |
125 | srcprops_freelist = (scm_t_srcprops *) &ptr[1]; | |
575888bd | 126 | } |
575888bd MD |
127 | ptr->pos = SRCPROPMAKPOS (line, col); |
128 | ptr->fname = filename; | |
129 | ptr->copy = copy; | |
130 | ptr->plist = plist; | |
216eedfc | 131 | SCM_ALLOW_INTS; |
23a62151 | 132 | SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr); |
575888bd MD |
133 | } |
134 | ||
1cc91f1b | 135 | |
575888bd | 136 | SCM |
7862b07e | 137 | scm_srcprops_to_plist (SCM obj) |
575888bd MD |
138 | { |
139 | SCM plist = SRCPROPPLIST (obj); | |
140 | if (!SCM_UNBNDP (SRCPROPCOPY (obj))) | |
92e5aa0e | 141 | plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist); |
575888bd | 142 | if (!SCM_UNBNDP (SRCPROPFNAME (obj))) |
92e5aa0e MD |
143 | plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist); |
144 | plist = scm_acons (scm_sym_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist); | |
145 | plist = scm_acons (scm_sym_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist); | |
c96d76b8 | 146 | plist = scm_acons (scm_sym_breakpoint, SCM_BOOL (SRCPROPBRK (obj)), plist); |
575888bd MD |
147 | return plist; |
148 | } | |
149 | ||
a1ec6916 | 150 | SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, |
1bbd0b84 | 151 | (SCM obj), |
e3239868 | 152 | "Return the source property association list of @var{obj}.") |
1bbd0b84 | 153 | #define FUNC_NAME s_scm_source_properties |
575888bd MD |
154 | { |
155 | SCM p; | |
34d19ef6 | 156 | SCM_VALIDATE_NIM (1, obj); |
575888bd | 157 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 | 158 | obj = SCM_MEMOIZED_EXP (obj); |
8505e285 | 159 | else if (!SCM_CONSP (obj)) |
1bbd0b84 | 160 | SCM_WRONG_TYPE_ARG (1, obj); |
f5003c13 | 161 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); |
230d095f | 162 | if (SRCPROPSP (p)) |
7862b07e | 163 | return scm_srcprops_to_plist (p); |
f5003c13 KR |
164 | else |
165 | /* list from set-source-properties!, or SCM_EOL for not found */ | |
166 | return p; | |
575888bd | 167 | } |
1bbd0b84 | 168 | #undef FUNC_NAME |
575888bd MD |
169 | |
170 | /* Perhaps this procedure should look through an alist | |
171 | and try to make a srcprops-object...? */ | |
a1ec6916 | 172 | SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, |
1bbd0b84 | 173 | (SCM obj, SCM plist), |
e3239868 DH |
174 | "Install the association list @var{plist} as the source property\n" |
175 | "list for @var{obj}.") | |
1bbd0b84 | 176 | #define FUNC_NAME s_scm_set_source_properties_x |
575888bd MD |
177 | { |
178 | SCM handle; | |
34d19ef6 | 179 | SCM_VALIDATE_NIM (1, obj); |
575888bd | 180 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 | 181 | obj = SCM_MEMOIZED_EXP (obj); |
8505e285 | 182 | else if (!SCM_CONSP (obj)) |
1bbd0b84 | 183 | SCM_WRONG_TYPE_ARG(1, obj); |
575888bd MD |
184 | handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); |
185 | SCM_SETCDR (handle, plist); | |
186 | return plist; | |
187 | } | |
1bbd0b84 | 188 | #undef FUNC_NAME |
575888bd | 189 | |
a1ec6916 | 190 | SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, |
1bbd0b84 | 191 | (SCM obj, SCM key), |
e3239868 DH |
192 | "Return the source property specified by @var{key} from\n" |
193 | "@var{obj}'s source property list.") | |
1bbd0b84 | 194 | #define FUNC_NAME s_scm_source_property |
575888bd MD |
195 | { |
196 | SCM p; | |
34d19ef6 | 197 | SCM_VALIDATE_NIM (1, obj); |
575888bd | 198 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 | 199 | obj = SCM_MEMOIZED_EXP (obj); |
8505e285 | 200 | else if (!SCM_CONSP (obj)) |
1bbd0b84 | 201 | SCM_WRONG_TYPE_ARG (1, obj); |
575888bd | 202 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); |
24933780 | 203 | if (!SRCPROPSP (p)) |
575888bd | 204 | goto plist; |
c96d76b8 | 205 | if (SCM_EQ_P (scm_sym_breakpoint, key)) p = SCM_BOOL (SRCPROPBRK (p)); |
54778cd3 DH |
206 | else if (SCM_EQ_P (scm_sym_line, key)) p = SCM_MAKINUM (SRCPROPLINE (p)); |
207 | else if (SCM_EQ_P (scm_sym_column, key)) p = SCM_MAKINUM (SRCPROPCOL (p)); | |
208 | else if (SCM_EQ_P (scm_sym_filename, key)) p = SRCPROPFNAME (p); | |
209 | else if (SCM_EQ_P (scm_sym_copy, key)) p = SRCPROPCOPY (p); | |
575888bd MD |
210 | else |
211 | { | |
212 | p = SRCPROPPLIST (p); | |
213 | plist: | |
214 | p = scm_assoc (key, p); | |
215 | return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); | |
216 | } | |
217 | return SCM_UNBNDP (p) ? SCM_BOOL_F : p; | |
218 | } | |
1bbd0b84 | 219 | #undef FUNC_NAME |
575888bd | 220 | |
a1ec6916 | 221 | SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, |
1bbd0b84 | 222 | (SCM obj, SCM key, SCM datum), |
e3239868 DH |
223 | "Set the source property of object @var{obj}, which is specified by\n" |
224 | "@var{key} to @var{datum}. Normally, the key will be a symbol.") | |
1bbd0b84 | 225 | #define FUNC_NAME s_scm_set_source_property_x |
575888bd MD |
226 | { |
227 | scm_whash_handle h; | |
228 | SCM p; | |
34d19ef6 | 229 | SCM_VALIDATE_NIM (1, obj); |
575888bd | 230 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 | 231 | obj = SCM_MEMOIZED_EXP (obj); |
8505e285 | 232 | else if (!SCM_CONSP (obj)) |
1bbd0b84 | 233 | SCM_WRONG_TYPE_ARG (1, obj); |
575888bd MD |
234 | h = scm_whash_get_handle (scm_source_whash, obj); |
235 | if (SCM_WHASHFOUNDP (h)) | |
236 | p = SCM_WHASHREF (scm_source_whash, h); | |
237 | else | |
238 | { | |
239 | h = scm_whash_create_handle (scm_source_whash, obj); | |
240 | p = SCM_EOL; | |
241 | } | |
54778cd3 | 242 | if (SCM_EQ_P (scm_sym_breakpoint, key)) |
cda139a7 | 243 | { |
62850ef3 DH |
244 | if (SRCPROPSP (p)) |
245 | { | |
246 | if (SCM_FALSEP (datum)) | |
247 | CLEARSRCPROPBRK (p); | |
248 | else | |
249 | SETSRCPROPBRK (p); | |
250 | } | |
cda139a7 | 251 | else |
62850ef3 DH |
252 | { |
253 | SCM sp = scm_make_srcprops (0, 0, SCM_UNDEFINED, SCM_UNDEFINED, p); | |
254 | SCM_WHASHSET (scm_source_whash, h, sp); | |
255 | if (SCM_FALSEP (datum)) | |
256 | CLEARSRCPROPBRK (sp); | |
257 | else | |
258 | SETSRCPROPBRK (sp); | |
259 | } | |
cda139a7 | 260 | } |
54778cd3 | 261 | else if (SCM_EQ_P (scm_sym_line, key)) |
575888bd | 262 | { |
34d19ef6 | 263 | SCM_VALIDATE_INUM (3, datum); |
0c95b57d | 264 | if (SRCPROPSP (p)) |
a9dbb9fd | 265 | SETSRCPROPLINE (p, SCM_INUM (datum)); |
575888bd MD |
266 | else |
267 | SCM_WHASHSET (scm_source_whash, h, | |
a9dbb9fd MD |
268 | scm_make_srcprops (SCM_INUM (datum), 0, |
269 | SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
575888bd | 270 | } |
54778cd3 | 271 | else if (SCM_EQ_P (scm_sym_column, key)) |
575888bd | 272 | { |
34d19ef6 | 273 | SCM_VALIDATE_INUM (3, datum); |
0c95b57d | 274 | if (SRCPROPSP (p)) |
a9dbb9fd | 275 | SETSRCPROPCOL (p, SCM_INUM (datum)); |
575888bd MD |
276 | else |
277 | SCM_WHASHSET (scm_source_whash, h, | |
a9dbb9fd MD |
278 | scm_make_srcprops (0, SCM_INUM (datum), |
279 | SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
575888bd | 280 | } |
54778cd3 | 281 | else if (SCM_EQ_P (scm_sym_filename, key)) |
575888bd | 282 | { |
0c95b57d | 283 | if (SRCPROPSP (p)) |
575888bd MD |
284 | SRCPROPFNAME (p) = datum; |
285 | else | |
5c5549cb | 286 | SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); |
575888bd | 287 | } |
0419a528 | 288 | else if (SCM_EQ_P (scm_sym_copy, key)) |
575888bd | 289 | { |
0c95b57d | 290 | if (SRCPROPSP (p)) |
575888bd MD |
291 | SRCPROPCOPY (p) = datum; |
292 | else | |
5c5549cb | 293 | SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); |
575888bd MD |
294 | } |
295 | else | |
58d233cc NJ |
296 | { |
297 | if (SRCPROPSP (p)) | |
298 | SRCPROPPLIST (p) = scm_acons (key, datum, SRCPROPPLIST (p)); | |
299 | else | |
300 | SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); | |
301 | } | |
575888bd MD |
302 | return SCM_UNSPECIFIED; |
303 | } | |
1bbd0b84 | 304 | #undef FUNC_NAME |
575888bd | 305 | |
1cc91f1b | 306 | |
575888bd MD |
307 | void |
308 | scm_init_srcprop () | |
575888bd | 309 | { |
e841c3e0 KN |
310 | scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0); |
311 | scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark); | |
312 | scm_set_smob_free (scm_tc16_srcprops, srcprops_free); | |
313 | scm_set_smob_print (scm_tc16_srcprops, srcprops_print); | |
314 | ||
5c5549cb | 315 | scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047)); |
86d31dfe | 316 | scm_c_define ("source-whash", scm_source_whash); |
85db4a2c | 317 | |
a0599745 | 318 | #include "libguile/srcprop.x" |
575888bd MD |
319 | } |
320 | ||
321 | void | |
322 | scm_finish_srcprop () | |
323 | { | |
92c2555f | 324 | register scm_t_srcprops_chunk *ptr = srcprops_chunklist, *next; |
0068984b HWN |
325 | size_t n= sizeof (scm_t_srcprops_chunk) |
326 | + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1); | |
575888bd MD |
327 | while (ptr) |
328 | { | |
329 | next = ptr->next; | |
0068984b | 330 | scm_gc_unregister_collectable_memory (ptr, n, "srcprops"); |
575888bd | 331 | free ((char *) ptr); |
5c5549cb | 332 | ptr = next; |
575888bd MD |
333 | } |
334 | } | |
89e00824 ML |
335 | |
336 | /* | |
337 | Local Variables: | |
338 | c-file-style: "gnu" | |
339 | End: | |
340 | */ |