Commit | Line | Data |
---|---|---|
78a0461a | 1 | /* Copyright (C) 1995, 1996, 1997, 1998, 1999 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 GB |
44 | |
45 | /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, | |
46 | gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ | |
47 | ||
575888bd MD |
48 | \f |
49 | ||
50 | #include <stdio.h> | |
51 | #include "_scm.h" | |
20e6290e JB |
52 | #include "smob.h" |
53 | #include "alist.h" | |
54 | #include "debug.h" | |
55 | #include "hashtab.h" | |
5c5549cb | 56 | #include "hash.h" |
f04d8caf | 57 | #include "ports.h" |
ba11fd4c | 58 | #include "root.h" |
20e6290e | 59 | #include "weaks.h" |
575888bd | 60 | |
b6791b2e | 61 | #include "validate.h" |
20e6290e | 62 | #include "srcprop.h" |
575888bd MD |
63 | \f |
64 | /* {Source Properties} | |
65 | * | |
66 | * Properties of source list expressions. | |
67 | * Five of these have special meaning and optimized storage: | |
68 | * | |
69 | * filename string The name of the source file. | |
70 | * copy list A copy of the list expression. | |
71 | * line integer The source code line number. | |
72 | * column integer The source code column number. | |
73 | * breakpoint boolean Sets a breakpoint on this form. | |
74 | * | |
75 | * Most properties above can be set by the reader. | |
76 | * | |
77 | */ | |
78 | ||
92e5aa0e MD |
79 | SCM scm_sym_filename; |
80 | SCM scm_sym_copy; | |
81 | SCM scm_sym_line; | |
82 | SCM scm_sym_column; | |
83 | SCM scm_sym_breakpoint; | |
575888bd | 84 | |
5c5549cb | 85 | long scm_tc16_srcprops; |
575888bd MD |
86 | static scm_srcprops_chunk *srcprops_chunklist = 0; |
87 | static scm_srcprops *srcprops_freelist = 0; | |
88 | ||
1cc91f1b | 89 | |
575888bd | 90 | static SCM |
1bbd0b84 | 91 | marksrcprops (SCM obj) |
575888bd | 92 | { |
575888bd MD |
93 | scm_gc_mark (SRCPROPFNAME (obj)); |
94 | scm_gc_mark (SRCPROPCOPY (obj)); | |
95 | return SRCPROPPLIST (obj); | |
96 | } | |
97 | ||
1cc91f1b | 98 | |
575888bd | 99 | static scm_sizet |
1bbd0b84 | 100 | freesrcprops (SCM obj) |
575888bd MD |
101 | { |
102 | *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist; | |
103 | srcprops_freelist = (scm_srcprops *) SCM_CDR (obj); | |
104 | return 0; /* srcprops_chunks are not freed until leaving guile */ | |
105 | } | |
106 | ||
1cc91f1b | 107 | |
575888bd | 108 | static int |
1bbd0b84 | 109 | prinsrcprops (SCM obj,SCM port,scm_print_state *pstate) |
575888bd | 110 | { |
19402679 | 111 | int writingp = SCM_WRITINGP (pstate); |
b7f3516f | 112 | scm_puts ("#<srcprops ", port); |
19402679 MD |
113 | SCM_SET_WRITINGP (pstate, 1); |
114 | scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate); | |
115 | SCM_SET_WRITINGP (pstate, writingp); | |
b7f3516f | 116 | scm_putc ('>', port); |
575888bd MD |
117 | return 1; |
118 | } | |
119 | ||
1cc91f1b | 120 | |
575888bd | 121 | SCM |
1bbd0b84 | 122 | scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist) |
575888bd | 123 | { |
575888bd MD |
124 | register scm_srcprops *ptr; |
125 | SCM_DEFER_INTS; | |
126 | if ((ptr = srcprops_freelist) != NULL) | |
127 | srcprops_freelist = *(scm_srcprops **)ptr; | |
128 | else | |
129 | { | |
130 | int i; | |
131 | scm_srcprops_chunk *mem; | |
132 | scm_sizet n = sizeof (scm_srcprops_chunk) | |
133 | + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); | |
134 | SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n)); | |
135 | SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops"); | |
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) | |
141 | *(scm_srcprops **)&ptr[i] = &ptr[i + 1]; | |
142 | *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; | |
143 | srcprops_freelist = (scm_srcprops *) &ptr[1]; | |
144 | } | |
575888bd MD |
145 | ptr->pos = SRCPROPMAKPOS (line, col); |
146 | ptr->fname = filename; | |
147 | ptr->copy = copy; | |
148 | ptr->plist = plist; | |
23a62151 | 149 | SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr); |
575888bd MD |
150 | } |
151 | ||
1cc91f1b | 152 | |
575888bd | 153 | SCM |
1bbd0b84 | 154 | scm_srcprops_to_plist (SCM obj) |
575888bd MD |
155 | { |
156 | SCM plist = SRCPROPPLIST (obj); | |
157 | if (!SCM_UNBNDP (SRCPROPCOPY (obj))) | |
92e5aa0e | 158 | plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist); |
575888bd | 159 | if (!SCM_UNBNDP (SRCPROPFNAME (obj))) |
92e5aa0e MD |
160 | plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist); |
161 | plist = scm_acons (scm_sym_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist); | |
162 | plist = scm_acons (scm_sym_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist); | |
163 | plist = scm_acons (scm_sym_breakpoint, SRCPROPBRK (obj), plist); | |
575888bd MD |
164 | return plist; |
165 | } | |
166 | ||
a1ec6916 | 167 | SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, |
1bbd0b84 | 168 | (SCM obj), |
717050c8 | 169 | "") |
1bbd0b84 | 170 | #define FUNC_NAME s_scm_source_properties |
575888bd MD |
171 | { |
172 | SCM p; | |
6b5a304f | 173 | SCM_VALIDATE_NIM (1,obj); |
575888bd | 174 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 MD |
175 | obj = SCM_MEMOIZED_EXP (obj); |
176 | #ifndef SCM_RECKLESS | |
177 | else if (SCM_NCONSP (obj)) | |
1bbd0b84 | 178 | SCM_WRONG_TYPE_ARG (1, obj); |
a4645b97 | 179 | #endif |
575888bd MD |
180 | p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL); |
181 | if (p != (SCM) NULL && SRCPROPSP (p)) | |
182 | return scm_srcprops_to_plist (p); | |
183 | return SCM_EOL; | |
184 | } | |
1bbd0b84 | 185 | #undef FUNC_NAME |
575888bd MD |
186 | |
187 | /* Perhaps this procedure should look through an alist | |
188 | and try to make a srcprops-object...? */ | |
a1ec6916 | 189 | SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, |
1bbd0b84 GB |
190 | (SCM obj, SCM plist), |
191 | "") | |
192 | #define FUNC_NAME s_scm_set_source_properties_x | |
575888bd MD |
193 | { |
194 | SCM handle; | |
6b5a304f | 195 | SCM_VALIDATE_NIM (1,obj); |
575888bd | 196 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 MD |
197 | obj = SCM_MEMOIZED_EXP (obj); |
198 | #ifndef SCM_RECKLESS | |
199 | else if (SCM_NCONSP (obj)) | |
1bbd0b84 | 200 | SCM_WRONG_TYPE_ARG(1, obj); |
a4645b97 | 201 | #endif |
575888bd MD |
202 | handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); |
203 | SCM_SETCDR (handle, plist); | |
204 | return plist; | |
205 | } | |
1bbd0b84 | 206 | #undef FUNC_NAME |
575888bd | 207 | |
a1ec6916 | 208 | SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, |
1bbd0b84 GB |
209 | (SCM obj, SCM key), |
210 | "") | |
211 | #define FUNC_NAME s_scm_source_property | |
575888bd MD |
212 | { |
213 | SCM p; | |
6b5a304f | 214 | SCM_VALIDATE_NIM (1,obj); |
575888bd | 215 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 MD |
216 | obj = SCM_MEMOIZED_EXP (obj); |
217 | #ifndef SCM_RECKLESS | |
09a56810 | 218 | else if (SCM_NECONSP (obj)) |
1bbd0b84 | 219 | SCM_WRONG_TYPE_ARG (1, obj); |
a4645b97 | 220 | #endif |
575888bd MD |
221 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); |
222 | if (SCM_IMP (p) || !SRCPROPSP (p)) | |
223 | goto plist; | |
92e5aa0e MD |
224 | if (scm_sym_breakpoint == key) p = SRCPROPBRK (p); |
225 | else if (scm_sym_line == key) p = SCM_MAKINUM (SRCPROPLINE (p)); | |
226 | else if (scm_sym_column == key) p = SCM_MAKINUM (SRCPROPCOL (p)); | |
227 | else if (scm_sym_filename == key) p = SRCPROPFNAME (p); | |
228 | else if (scm_sym_copy == key) p = SRCPROPCOPY (p); | |
575888bd MD |
229 | else |
230 | { | |
231 | p = SRCPROPPLIST (p); | |
232 | plist: | |
233 | p = scm_assoc (key, p); | |
234 | return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); | |
235 | } | |
236 | return SCM_UNBNDP (p) ? SCM_BOOL_F : p; | |
237 | } | |
1bbd0b84 | 238 | #undef FUNC_NAME |
575888bd | 239 | |
a1ec6916 | 240 | SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, |
1bbd0b84 GB |
241 | (SCM obj, SCM key, SCM datum), |
242 | "") | |
243 | #define FUNC_NAME s_scm_set_source_property_x | |
575888bd MD |
244 | { |
245 | scm_whash_handle h; | |
246 | SCM p; | |
6b5a304f | 247 | SCM_VALIDATE_NIM (1,obj); |
575888bd | 248 | if (SCM_MEMOIZEDP (obj)) |
a4645b97 MD |
249 | obj = SCM_MEMOIZED_EXP (obj); |
250 | #ifndef SCM_RECKLESS | |
251 | else if (SCM_NCONSP (obj)) | |
1bbd0b84 | 252 | SCM_WRONG_TYPE_ARG (1, obj); |
a4645b97 | 253 | #endif |
575888bd MD |
254 | h = scm_whash_get_handle (scm_source_whash, obj); |
255 | if (SCM_WHASHFOUNDP (h)) | |
256 | p = SCM_WHASHREF (scm_source_whash, h); | |
257 | else | |
258 | { | |
259 | h = scm_whash_create_handle (scm_source_whash, obj); | |
260 | p = SCM_EOL; | |
261 | } | |
92e5aa0e | 262 | if (scm_sym_breakpoint == key) |
cda139a7 MD |
263 | { |
264 | if (SCM_FALSEP (datum)) | |
0c95b57d | 265 | CLEARSRCPROPBRK (SRCPROPSP (p) |
cda139a7 MD |
266 | ? p |
267 | : SCM_WHASHSET (scm_source_whash, h, | |
268 | scm_make_srcprops (0, | |
269 | 0, | |
270 | SCM_UNDEFINED, | |
271 | SCM_UNDEFINED, | |
272 | p))); | |
273 | else | |
0c95b57d | 274 | SETSRCPROPBRK (SRCPROPSP (p) |
575888bd MD |
275 | ? p |
276 | : SCM_WHASHSET (scm_source_whash, h, | |
cda139a7 MD |
277 | scm_make_srcprops (0, |
278 | 0, | |
279 | SCM_UNDEFINED, | |
280 | SCM_UNDEFINED, | |
281 | p))); | |
282 | } | |
92e5aa0e | 283 | else if (scm_sym_line == key) |
575888bd | 284 | { |
3b3b36dd | 285 | SCM_VALIDATE_INUM (3,datum); |
0c95b57d | 286 | if (SRCPROPSP (p)) |
a9dbb9fd | 287 | SETSRCPROPLINE (p, SCM_INUM (datum)); |
575888bd MD |
288 | else |
289 | SCM_WHASHSET (scm_source_whash, h, | |
a9dbb9fd MD |
290 | scm_make_srcprops (SCM_INUM (datum), 0, |
291 | SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
575888bd | 292 | } |
92e5aa0e | 293 | else if (scm_sym_column == key) |
575888bd | 294 | { |
3b3b36dd | 295 | SCM_VALIDATE_INUM (3,datum); |
0c95b57d | 296 | if (SRCPROPSP (p)) |
a9dbb9fd | 297 | SETSRCPROPCOL (p, SCM_INUM (datum)); |
575888bd MD |
298 | else |
299 | SCM_WHASHSET (scm_source_whash, h, | |
a9dbb9fd MD |
300 | scm_make_srcprops (0, SCM_INUM (datum), |
301 | SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
575888bd | 302 | } |
92e5aa0e | 303 | else if (scm_sym_filename == key) |
575888bd | 304 | { |
0c95b57d | 305 | if (SRCPROPSP (p)) |
575888bd MD |
306 | SRCPROPFNAME (p) = datum; |
307 | else | |
5c5549cb | 308 | SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); |
575888bd | 309 | } |
92e5aa0e | 310 | else if (scm_sym_filename == key) |
575888bd | 311 | { |
0c95b57d | 312 | if (SRCPROPSP (p)) |
575888bd MD |
313 | SRCPROPCOPY (p) = datum; |
314 | else | |
5c5549cb | 315 | SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); |
575888bd MD |
316 | } |
317 | else | |
318 | SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); | |
319 | return SCM_UNSPECIFIED; | |
320 | } | |
1bbd0b84 | 321 | #undef FUNC_NAME |
575888bd | 322 | |
1cc91f1b | 323 | |
575888bd MD |
324 | void |
325 | scm_init_srcprop () | |
575888bd | 326 | { |
23a62151 MD |
327 | scm_tc16_srcprops = scm_make_smob_type_mfpe ("srcprops", 0, |
328 | marksrcprops, freesrcprops, prinsrcprops, NULL); | |
5c5549cb | 329 | scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047)); |
575888bd | 330 | |
92e5aa0e MD |
331 | scm_sym_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED)); |
332 | scm_sym_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED)); | |
333 | scm_sym_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED)); | |
334 | scm_sym_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED)); | |
335 | scm_sym_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED)); | |
575888bd MD |
336 | |
337 | scm_sysintern ("source-whash", scm_source_whash); | |
338 | #include "srcprop.x" | |
339 | } | |
340 | ||
341 | void | |
342 | scm_finish_srcprop () | |
343 | { | |
344 | register scm_srcprops_chunk *ptr = srcprops_chunklist, *next; | |
345 | while (ptr) | |
346 | { | |
347 | next = ptr->next; | |
348 | free ((char *) ptr); | |
349 | scm_mallocated -= sizeof (scm_srcprops_chunk) | |
350 | + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); | |
5c5549cb | 351 | ptr = next; |
575888bd MD |
352 | } |
353 | } | |
89e00824 ML |
354 | |
355 | /* | |
356 | Local Variables: | |
357 | c-file-style: "gnu" | |
358 | End: | |
359 | */ |