Commit | Line | Data |
---|---|---|
216eedfc | 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation |
575888bd MD |
2 | * |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program 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 | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
575888bd MD |
17 | * |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
40 | * If you do not wish that, delete this exception notice. | |
41 | * | |
42 | * The author can be reached at djurfeldt@nada.kth.se | |
82892bed | 43 | * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ |
1bbd0b84 | 44 | |
1bbd0b84 | 45 | |
575888bd MD |
46 | \f |
47 | ||
e6e2e95a MD |
48 | #include <errno.h> |
49 | ||
a0599745 MD |
50 | #include "libguile/_scm.h" |
51 | #include "libguile/smob.h" | |
52 | #include "libguile/alist.h" | |
53 | #include "libguile/debug.h" | |
54 | #include "libguile/hashtab.h" | |
55 | #include "libguile/hash.h" | |
56 | #include "libguile/ports.h" | |
57 | #include "libguile/root.h" | |
58 | #include "libguile/weaks.h" | |
575888bd | 59 | |
a0599745 MD |
60 | #include "libguile/validate.h" |
61 | #include "libguile/srcprop.h" | |
575888bd MD |
62 | \f |
63 | /* {Source Properties} | |
64 | * | |
65 | * Properties of source list expressions. | |
66 | * Five of these have special meaning and optimized storage: | |
67 | * | |
68 | * filename string The name of the source file. | |
69 | * copy list A copy of the list expression. | |
70 | * line integer The source code line number. | |
71 | * column integer The source code column number. | |
72 | * breakpoint boolean Sets a breakpoint on this form. | |
73 | * | |
74 | * Most properties above can be set by the reader. | |
75 | * | |
76 | */ | |
77 | ||
85db4a2c DH |
78 | SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); |
79 | SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy"); | |
80 | SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); | |
81 | SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); | |
82 | SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); | |
575888bd | 83 | |
92c2555f MV |
84 | scm_t_bits scm_tc16_srcprops; |
85 | static scm_t_srcprops_chunk *srcprops_chunklist = 0; | |
86 | static scm_t_srcprops *srcprops_freelist = 0; | |
575888bd | 87 | |
1cc91f1b | 88 | |
575888bd | 89 | static SCM |
e841c3e0 | 90 | srcprops_mark (SCM obj) |
575888bd | 91 | { |
575888bd MD |
92 | scm_gc_mark (SRCPROPFNAME (obj)); |
93 | scm_gc_mark (SRCPROPCOPY (obj)); | |
94 | return SRCPROPPLIST (obj); | |
95 | } | |
96 | ||
1cc91f1b | 97 | |
1be6b49c | 98 | static size_t |
e841c3e0 | 99 | srcprops_free (SCM obj) |
575888bd | 100 | { |
92c2555f MV |
101 | *((scm_t_srcprops **) SCM_CELL_WORD_1 (obj)) = srcprops_freelist; |
102 | srcprops_freelist = (scm_t_srcprops *) SCM_CELL_WORD_1 (obj); | |
575888bd MD |
103 | return 0; /* srcprops_chunks are not freed until leaving guile */ |
104 | } | |
105 | ||
1cc91f1b | 106 | |
575888bd | 107 | static int |
e841c3e0 | 108 | srcprops_print (SCM obj, SCM port, scm_print_state *pstate) |
575888bd | 109 | { |
19402679 | 110 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 111 | scm_puts ("#<srcprops ", port); |
19402679 | 112 | SCM_SET_WRITINGP (pstate, 1); |
7862b07e | 113 | scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate); |
19402679 | 114 | SCM_SET_WRITINGP (pstate, writingp); |
b7f3516f | 115 | scm_putc ('>', port); |
575888bd MD |
116 | return 1; |
117 | } | |
118 | ||
1cc91f1b | 119 | |
575888bd | 120 | SCM |
1be6b49c | 121 | scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) |
575888bd | 122 | { |
92c2555f | 123 | register scm_t_srcprops *ptr; |
575888bd MD |
124 | SCM_DEFER_INTS; |
125 | if ((ptr = srcprops_freelist) != NULL) | |
92c2555f | 126 | srcprops_freelist = *(scm_t_srcprops **)ptr; |
575888bd MD |
127 | else |
128 | { | |
1be6b49c | 129 | size_t i; |
92c2555f MV |
130 | scm_t_srcprops_chunk *mem; |
131 | size_t n = sizeof (scm_t_srcprops_chunk) | |
132 | + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1); | |
133 | SCM_SYSCALL (mem = (scm_t_srcprops_chunk *) malloc (n)); | |
2500356c DH |
134 | if (mem == NULL) |
135 | scm_memory_error ("srcprops"); | |
575888bd MD |
136 | scm_mallocated += n; |
137 | mem->next = srcprops_chunklist; | |
138 | srcprops_chunklist = mem; | |
139 | ptr = &mem->srcprops[0]; | |
140 | for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i) | |
92c2555f MV |
141 | *(scm_t_srcprops **)&ptr[i] = &ptr[i + 1]; |
142 | *(scm_t_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; | |
143 | srcprops_freelist = (scm_t_srcprops *) &ptr[1]; | |
575888bd | 144 | } |
575888bd MD |
145 | ptr->pos = SRCPROPMAKPOS (line, col); |
146 | ptr->fname = filename; | |
147 | ptr->copy = copy; | |
148 | ptr->plist = plist; | |
216eedfc | 149 | SCM_ALLOW_INTS; |
23a62151 | 150 | SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr); |
575888bd MD |
151 | } |
152 | ||
1cc91f1b | 153 | |
575888bd | 154 | SCM |
7862b07e | 155 | scm_srcprops_to_plist (SCM obj) |
575888bd MD |
156 | { |
157 | SCM plist = SRCPROPPLIST (obj); | |
158 | if (!SCM_UNBNDP (SRCPROPCOPY (obj))) | |
92e5aa0e | 159 | plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist); |
575888bd | 160 | if (!SCM_UNBNDP (SRCPROPFNAME (obj))) |
92e5aa0e MD |
161 | plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist); |
162 | plist = scm_acons (scm_sym_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist); | |
163 | plist = scm_acons (scm_sym_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist); | |
c96d76b8 | 164 | plist = scm_acons (scm_sym_breakpoint, SCM_BOOL (SRCPROPBRK (obj)), plist); |
575888bd MD |
165 | return plist; |
166 | } | |
167 | ||
a1ec6916 | 168 | SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, |
1bbd0b84 | 169 | (SCM obj), |
e3239868 | 170 | "Return the source property association list of @var{obj}.") |
1bbd0b84 | 171 | #define FUNC_NAME s_scm_source_properties |
575888bd MD |
172 | { |
173 | SCM p; | |
6b5a304f | 174 | SCM_VALIDATE_NIM (1,obj); |
575888bd | 175 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 MD |
176 | obj = SCM_MEMOIZED_EXP (obj); |
177 | #ifndef SCM_RECKLESS | |
178 | else if (SCM_NCONSP (obj)) | |
1bbd0b84 | 179 | SCM_WRONG_TYPE_ARG (1, obj); |
a4645b97 | 180 | #endif |
230d095f DH |
181 | p = scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F); |
182 | if (SRCPROPSP (p)) | |
7862b07e | 183 | return scm_srcprops_to_plist (p); |
575888bd MD |
184 | return SCM_EOL; |
185 | } | |
1bbd0b84 | 186 | #undef FUNC_NAME |
575888bd MD |
187 | |
188 | /* Perhaps this procedure should look through an alist | |
189 | and try to make a srcprops-object...? */ | |
a1ec6916 | 190 | SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, |
1bbd0b84 | 191 | (SCM obj, SCM plist), |
e3239868 DH |
192 | "Install the association list @var{plist} as the source property\n" |
193 | "list for @var{obj}.") | |
1bbd0b84 | 194 | #define FUNC_NAME s_scm_set_source_properties_x |
575888bd MD |
195 | { |
196 | SCM handle; | |
6b5a304f | 197 | SCM_VALIDATE_NIM (1,obj); |
575888bd | 198 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 MD |
199 | obj = SCM_MEMOIZED_EXP (obj); |
200 | #ifndef SCM_RECKLESS | |
201 | else if (SCM_NCONSP (obj)) | |
1bbd0b84 | 202 | SCM_WRONG_TYPE_ARG(1, obj); |
a4645b97 | 203 | #endif |
575888bd MD |
204 | handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); |
205 | SCM_SETCDR (handle, plist); | |
206 | return plist; | |
207 | } | |
1bbd0b84 | 208 | #undef FUNC_NAME |
575888bd | 209 | |
a1ec6916 | 210 | SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, |
1bbd0b84 | 211 | (SCM obj, SCM key), |
e3239868 DH |
212 | "Return the source property specified by @var{key} from\n" |
213 | "@var{obj}'s source property list.") | |
1bbd0b84 | 214 | #define FUNC_NAME s_scm_source_property |
575888bd MD |
215 | { |
216 | SCM p; | |
6b5a304f | 217 | SCM_VALIDATE_NIM (1,obj); |
575888bd | 218 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 MD |
219 | obj = SCM_MEMOIZED_EXP (obj); |
220 | #ifndef SCM_RECKLESS | |
904a077d | 221 | else if (SCM_NCONSP (obj)) |
1bbd0b84 | 222 | SCM_WRONG_TYPE_ARG (1, obj); |
a4645b97 | 223 | #endif |
575888bd | 224 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); |
24933780 | 225 | if (!SRCPROPSP (p)) |
575888bd | 226 | goto plist; |
c96d76b8 | 227 | if (SCM_EQ_P (scm_sym_breakpoint, key)) p = SCM_BOOL (SRCPROPBRK (p)); |
54778cd3 DH |
228 | else if (SCM_EQ_P (scm_sym_line, key)) p = SCM_MAKINUM (SRCPROPLINE (p)); |
229 | else if (SCM_EQ_P (scm_sym_column, key)) p = SCM_MAKINUM (SRCPROPCOL (p)); | |
230 | else if (SCM_EQ_P (scm_sym_filename, key)) p = SRCPROPFNAME (p); | |
231 | else if (SCM_EQ_P (scm_sym_copy, key)) p = SRCPROPCOPY (p); | |
575888bd MD |
232 | else |
233 | { | |
234 | p = SRCPROPPLIST (p); | |
235 | plist: | |
236 | p = scm_assoc (key, p); | |
237 | return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); | |
238 | } | |
239 | return SCM_UNBNDP (p) ? SCM_BOOL_F : p; | |
240 | } | |
1bbd0b84 | 241 | #undef FUNC_NAME |
575888bd | 242 | |
a1ec6916 | 243 | SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, |
1bbd0b84 | 244 | (SCM obj, SCM key, SCM datum), |
e3239868 DH |
245 | "Set the source property of object @var{obj}, which is specified by\n" |
246 | "@var{key} to @var{datum}. Normally, the key will be a symbol.") | |
1bbd0b84 | 247 | #define FUNC_NAME s_scm_set_source_property_x |
575888bd MD |
248 | { |
249 | scm_whash_handle h; | |
250 | SCM p; | |
6b5a304f | 251 | SCM_VALIDATE_NIM (1,obj); |
575888bd | 252 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 MD |
253 | obj = SCM_MEMOIZED_EXP (obj); |
254 | #ifndef SCM_RECKLESS | |
255 | else if (SCM_NCONSP (obj)) | |
1bbd0b84 | 256 | SCM_WRONG_TYPE_ARG (1, obj); |
a4645b97 | 257 | #endif |
575888bd MD |
258 | h = scm_whash_get_handle (scm_source_whash, obj); |
259 | if (SCM_WHASHFOUNDP (h)) | |
260 | p = SCM_WHASHREF (scm_source_whash, h); | |
261 | else | |
262 | { | |
263 | h = scm_whash_create_handle (scm_source_whash, obj); | |
264 | p = SCM_EOL; | |
265 | } | |
54778cd3 | 266 | if (SCM_EQ_P (scm_sym_breakpoint, key)) |
cda139a7 | 267 | { |
62850ef3 DH |
268 | if (SRCPROPSP (p)) |
269 | { | |
270 | if (SCM_FALSEP (datum)) | |
271 | CLEARSRCPROPBRK (p); | |
272 | else | |
273 | SETSRCPROPBRK (p); | |
274 | } | |
cda139a7 | 275 | else |
62850ef3 DH |
276 | { |
277 | SCM sp = scm_make_srcprops (0, 0, SCM_UNDEFINED, SCM_UNDEFINED, p); | |
278 | SCM_WHASHSET (scm_source_whash, h, sp); | |
279 | if (SCM_FALSEP (datum)) | |
280 | CLEARSRCPROPBRK (sp); | |
281 | else | |
282 | SETSRCPROPBRK (sp); | |
283 | } | |
cda139a7 | 284 | } |
54778cd3 | 285 | else if (SCM_EQ_P (scm_sym_line, key)) |
575888bd | 286 | { |
3b3b36dd | 287 | SCM_VALIDATE_INUM (3,datum); |
0c95b57d | 288 | if (SRCPROPSP (p)) |
a9dbb9fd | 289 | SETSRCPROPLINE (p, SCM_INUM (datum)); |
575888bd MD |
290 | else |
291 | SCM_WHASHSET (scm_source_whash, h, | |
a9dbb9fd MD |
292 | scm_make_srcprops (SCM_INUM (datum), 0, |
293 | SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
575888bd | 294 | } |
54778cd3 | 295 | else if (SCM_EQ_P (scm_sym_column, key)) |
575888bd | 296 | { |
3b3b36dd | 297 | SCM_VALIDATE_INUM (3,datum); |
0c95b57d | 298 | if (SRCPROPSP (p)) |
a9dbb9fd | 299 | SETSRCPROPCOL (p, SCM_INUM (datum)); |
575888bd MD |
300 | else |
301 | SCM_WHASHSET (scm_source_whash, h, | |
a9dbb9fd MD |
302 | scm_make_srcprops (0, SCM_INUM (datum), |
303 | SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
575888bd | 304 | } |
54778cd3 | 305 | else if (SCM_EQ_P (scm_sym_filename, key)) |
575888bd | 306 | { |
0c95b57d | 307 | if (SRCPROPSP (p)) |
575888bd MD |
308 | SRCPROPFNAME (p) = datum; |
309 | else | |
5c5549cb | 310 | SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); |
575888bd | 311 | } |
0419a528 | 312 | else if (SCM_EQ_P (scm_sym_copy, key)) |
575888bd | 313 | { |
0c95b57d | 314 | if (SRCPROPSP (p)) |
575888bd MD |
315 | SRCPROPCOPY (p) = datum; |
316 | else | |
5c5549cb | 317 | SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); |
575888bd MD |
318 | } |
319 | else | |
320 | SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); | |
321 | return SCM_UNSPECIFIED; | |
322 | } | |
1bbd0b84 | 323 | #undef FUNC_NAME |
575888bd | 324 | |
1cc91f1b | 325 | |
575888bd MD |
326 | void |
327 | scm_init_srcprop () | |
575888bd | 328 | { |
e841c3e0 KN |
329 | scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0); |
330 | scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark); | |
331 | scm_set_smob_free (scm_tc16_srcprops, srcprops_free); | |
332 | scm_set_smob_print (scm_tc16_srcprops, srcprops_print); | |
333 | ||
5c5549cb | 334 | scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047)); |
86d31dfe | 335 | scm_c_define ("source-whash", scm_source_whash); |
85db4a2c | 336 | |
8dc9439f | 337 | #ifndef SCM_MAGIC_SNARFER |
a0599745 | 338 | #include "libguile/srcprop.x" |
8dc9439f | 339 | #endif |
575888bd MD |
340 | } |
341 | ||
342 | void | |
343 | scm_finish_srcprop () | |
344 | { | |
92c2555f | 345 | register scm_t_srcprops_chunk *ptr = srcprops_chunklist, *next; |
575888bd MD |
346 | while (ptr) |
347 | { | |
348 | next = ptr->next; | |
349 | free ((char *) ptr); | |
92c2555f MV |
350 | scm_mallocated -= sizeof (scm_t_srcprops_chunk) |
351 | + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1); | |
5c5549cb | 352 | ptr = next; |
575888bd MD |
353 | } |
354 | } | |
89e00824 ML |
355 | |
356 | /* | |
357 | Local Variables: | |
358 | c-file-style: "gnu" | |
359 | End: | |
360 | */ |