Commit | Line | Data |
---|---|---|
575888bd MD |
1 | /* Copyright (C) 1995,1996 Mikael Djurfeldt |
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 | |
15 | * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
16 | * | |
17 | * As a special exception, the Free Software Foundation gives permission | |
18 | * for additional uses of the text contained in its release of GUILE. | |
19 | * | |
20 | * The exception is that, if you link the GUILE library with other files | |
21 | * to produce an executable, this does not by itself cause the | |
22 | * resulting executable to be covered by the GNU General Public License. | |
23 | * Your use of that executable is in no way restricted on account of | |
24 | * linking the GUILE library code into it. | |
25 | * | |
26 | * This exception does not however invalidate any other reasons why | |
27 | * the executable file might be covered by the GNU General Public License. | |
28 | * | |
29 | * This exception applies only to the code released by the | |
30 | * Free Software Foundation under the name GUILE. If you copy | |
31 | * code from other Free Software Foundation releases into a copy of | |
32 | * GUILE, as the General Public License permits, the exception does | |
33 | * not apply to the code that you add in this way. To avoid misleading | |
34 | * anyone as to the status of such modified files, you must delete | |
35 | * this exception notice from them. | |
36 | * | |
37 | * If you write modifications of your own for GUILE, it is your choice | |
38 | * whether to permit this exception to apply to your modifications. | |
39 | * If you do not wish that, delete this exception notice. | |
40 | * | |
41 | * The author can be reached at djurfeldt@nada.kth.se | |
42 | * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN | |
43 | */ | |
44 | \f | |
45 | ||
46 | #include <stdio.h> | |
47 | #include "_scm.h" | |
48 | ||
49 | \f | |
50 | /* {Source Properties} | |
51 | * | |
52 | * Properties of source list expressions. | |
53 | * Five of these have special meaning and optimized storage: | |
54 | * | |
55 | * filename string The name of the source file. | |
56 | * copy list A copy of the list expression. | |
57 | * line integer The source code line number. | |
58 | * column integer The source code column number. | |
59 | * breakpoint boolean Sets a breakpoint on this form. | |
60 | * | |
61 | * Most properties above can be set by the reader. | |
62 | * | |
63 | */ | |
64 | ||
65 | SCM scm_i_copy; | |
66 | static SCM scm_i_breakpoint, scm_i_line, scm_i_column; | |
67 | static SCM scm_i_filename; | |
68 | ||
69 | long tc16_srcprops; | |
70 | static scm_srcprops_chunk *srcprops_chunklist = 0; | |
71 | static scm_srcprops *srcprops_freelist = 0; | |
72 | ||
73 | #ifdef __STDC__ | |
74 | static SCM | |
75 | marksrcprops (SCM obj) | |
76 | #else | |
77 | static SCM | |
78 | marksrcprops (obj) | |
79 | SCM obj; | |
80 | #endif | |
81 | { | |
82 | SCM_SETGC8MARK (obj); | |
83 | scm_gc_mark (SRCPROPFNAME (obj)); | |
84 | scm_gc_mark (SRCPROPCOPY (obj)); | |
85 | return SRCPROPPLIST (obj); | |
86 | } | |
87 | ||
88 | #ifdef __STDC__ | |
89 | static scm_sizet | |
90 | freesrcprops (SCM obj) | |
91 | #else | |
92 | static scm_sizet | |
93 | freesrcprops (obj) | |
94 | SCM obj; | |
95 | #endif | |
96 | { | |
97 | *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist; | |
98 | srcprops_freelist = (scm_srcprops *) SCM_CDR (obj); | |
99 | return 0; /* srcprops_chunks are not freed until leaving guile */ | |
100 | } | |
101 | ||
102 | #ifdef __STDC__ | |
103 | static int | |
104 | prinsrcprops (SCM obj, SCM port, int writing) | |
105 | #else | |
106 | static int | |
107 | prinsrcprops (obj, port, writing) | |
108 | SCM obj; | |
109 | SCM port; | |
110 | int writing; | |
111 | #endif | |
112 | { | |
113 | scm_gen_puts (scm_regular_string, "#<srcprops ", port); | |
114 | scm_iprin1 (scm_srcprops_to_plist (obj), port, 1); | |
115 | scm_gen_putc ('>', port); | |
116 | return 1; | |
117 | } | |
118 | ||
119 | static scm_smobfuns srcpropssmob = | |
120 | {marksrcprops, freesrcprops, prinsrcprops, 0}; | |
121 | ||
122 | #ifdef __STDC__ | |
123 | SCM | |
124 | _scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist) | |
125 | #else | |
126 | SCM | |
127 | _scm_make_srcprops (line, col, filename, copy, plist) | |
128 | int line; | |
129 | int col; | |
130 | SCM filename; | |
131 | SCM copy; | |
132 | SCM plist; | |
133 | #endif | |
134 | { | |
135 | register SCM ans; | |
136 | register scm_srcprops *ptr; | |
137 | SCM_DEFER_INTS; | |
138 | if ((ptr = srcprops_freelist) != NULL) | |
139 | srcprops_freelist = *(scm_srcprops **)ptr; | |
140 | else | |
141 | { | |
142 | int i; | |
143 | scm_srcprops_chunk *mem; | |
144 | scm_sizet n = sizeof (scm_srcprops_chunk) | |
145 | + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); | |
146 | SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n)); | |
147 | SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops"); | |
148 | scm_mallocated += n; | |
149 | mem->next = srcprops_chunklist; | |
150 | srcprops_chunklist = mem; | |
151 | ptr = &mem->srcprops[0]; | |
152 | for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i) | |
153 | *(scm_srcprops **)&ptr[i] = &ptr[i + 1]; | |
154 | *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; | |
155 | srcprops_freelist = (scm_srcprops *) &ptr[1]; | |
156 | } | |
157 | SCM_NEWCELL (ans); | |
158 | SCM_CAR (ans) = tc16_srcprops; | |
159 | ptr->pos = SRCPROPMAKPOS (line, col); | |
160 | ptr->fname = filename; | |
161 | ptr->copy = copy; | |
162 | ptr->plist = plist; | |
163 | SCM_CDR (ans) = (SCM) ptr; | |
164 | SCM_ALLOW_INTS; | |
165 | return ans; | |
166 | } | |
167 | ||
168 | #ifdef __STDC__ | |
169 | SCM | |
170 | scm_srcprops_to_plist (SCM obj) | |
171 | #else | |
172 | SCM | |
173 | scm_srcprops_to_plist (obj) | |
174 | SCM obj; | |
175 | #endif | |
176 | { | |
177 | SCM plist = SRCPROPPLIST (obj); | |
178 | if (!SCM_UNBNDP (SRCPROPCOPY (obj))) | |
179 | plist = scm_acons (scm_i_copy, SRCPROPCOPY (obj), plist); | |
180 | if (!SCM_UNBNDP (SRCPROPFNAME (obj))) | |
181 | plist = scm_acons (scm_i_filename, SRCPROPFNAME (obj), plist); | |
182 | plist = scm_acons (scm_i_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist); | |
183 | plist = scm_acons (scm_i_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist); | |
184 | plist = scm_acons (scm_i_breakpoint, SRCPROPBRK (obj), plist); | |
185 | return plist; | |
186 | } | |
187 | ||
188 | SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties); | |
189 | #ifdef __STDC__ | |
190 | SCM | |
191 | scm_source_properties (SCM obj) | |
192 | #else | |
193 | SCM | |
194 | scm_source_properties (obj) | |
195 | SCM obj; | |
196 | #endif | |
197 | { | |
198 | SCM p; | |
199 | if (SCM_MEMOIZEDP (obj)) | |
200 | obj = SCM_MEMOEXP (obj); | |
201 | p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL); | |
202 | if (p != (SCM) NULL && SRCPROPSP (p)) | |
203 | return scm_srcprops_to_plist (p); | |
204 | return SCM_EOL; | |
205 | } | |
206 | ||
207 | /* Perhaps this procedure should look through an alist | |
208 | and try to make a srcprops-object...? */ | |
209 | SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x); | |
210 | #ifdef __STDC__ | |
211 | SCM | |
212 | scm_set_source_properties_x (SCM obj, SCM plist) | |
213 | #else | |
214 | SCM | |
215 | scm_set_source_properties_x (obj, plist) | |
216 | SCM obj; | |
217 | SCM plist; | |
218 | #endif | |
219 | { | |
220 | SCM handle; | |
221 | if (SCM_MEMOIZEDP (obj)) | |
222 | obj = SCM_MEMOEXP (obj); | |
223 | handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); | |
224 | SCM_SETCDR (handle, plist); | |
225 | return plist; | |
226 | } | |
227 | ||
228 | SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property); | |
229 | #ifdef __STDC__ | |
230 | SCM | |
231 | scm_source_property (SCM obj, SCM key) | |
232 | #else | |
233 | SCM | |
234 | scm_source_property (obj, key) | |
235 | SCM obj; | |
236 | SCM key; | |
237 | #endif | |
238 | { | |
239 | SCM p; | |
240 | if (SCM_MEMOIZEDP (obj)) | |
241 | obj = SCM_MEMOEXP (obj); | |
242 | p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); | |
243 | if (SCM_IMP (p) || !SRCPROPSP (p)) | |
244 | goto plist; | |
245 | if (scm_i_breakpoint == key) p = SRCPROPBRK (p); | |
246 | else if (scm_i_line == key) p = SCM_MAKINUM (SRCPROPLINE (p)); | |
247 | else if (scm_i_column == key) p = SCM_MAKINUM (SRCPROPCOL (p)); | |
248 | else if (scm_i_filename == key) p = SRCPROPFNAME (p); | |
249 | else if (scm_i_copy == key) p = SRCPROPCOPY (p); | |
250 | else | |
251 | { | |
252 | p = SRCPROPPLIST (p); | |
253 | plist: | |
254 | p = scm_assoc (key, p); | |
255 | return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); | |
256 | } | |
257 | return SCM_UNBNDP (p) ? SCM_BOOL_F : p; | |
258 | } | |
259 | ||
260 | SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x); | |
261 | #ifdef __STDC__ | |
262 | SCM | |
263 | scm_set_source_property_x (SCM obj, SCM key, SCM datum) | |
264 | #else | |
265 | SCM | |
266 | scm_set_source_property_x (obj, key, datum) | |
267 | SCM obj; | |
268 | SCM key; | |
269 | SCM datum; | |
270 | #endif | |
271 | { | |
272 | scm_whash_handle h; | |
273 | SCM p; | |
274 | if (SCM_MEMOIZEDP (obj)) | |
275 | obj = SCM_MEMOEXP (obj); | |
276 | h = scm_whash_get_handle (scm_source_whash, obj); | |
277 | if (SCM_WHASHFOUNDP (h)) | |
278 | p = SCM_WHASHREF (scm_source_whash, h); | |
279 | else | |
280 | { | |
281 | h = scm_whash_create_handle (scm_source_whash, obj); | |
282 | p = SCM_EOL; | |
283 | } | |
284 | if (scm_i_breakpoint == key) | |
285 | if (SCM_FALSEP (datum)) | |
286 | CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p) | |
287 | ? p | |
288 | : SCM_WHASHSET (scm_source_whash, h, | |
289 | _scm_make_srcprops (0, 0, SCM_UNDEFINED, | |
290 | SCM_UNDEFINED, p))); | |
291 | else | |
292 | SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p) | |
293 | ? p | |
294 | : SCM_WHASHSET (scm_source_whash, h, | |
295 | _scm_make_srcprops (0, 0, SCM_UNDEFINED, | |
296 | SCM_UNDEFINED, p))); | |
297 | else if (scm_i_line == key) | |
298 | { | |
299 | if (SCM_NIMP (p) && SRCPROPSP (p)) | |
300 | SETSRCPROPLINE (p, datum); | |
301 | else | |
302 | SCM_WHASHSET (scm_source_whash, h, | |
303 | _scm_make_srcprops (datum, 0, SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
304 | } | |
305 | else if (scm_i_column == key) | |
306 | { | |
307 | if (SCM_NIMP (p) && SRCPROPSP (p)) | |
308 | SETSRCPROPCOL (p, datum); | |
309 | else | |
310 | SCM_WHASHSET (scm_source_whash, h, | |
311 | _scm_make_srcprops (0, datum, SCM_UNDEFINED, SCM_UNDEFINED, p)); | |
312 | } | |
313 | else if (scm_i_filename == key) | |
314 | { | |
315 | if (SCM_NIMP (p) && SRCPROPSP (p)) | |
316 | SRCPROPFNAME (p) = datum; | |
317 | else | |
318 | SCM_WHASHSET (scm_source_whash, h, _scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); | |
319 | } | |
320 | else if (scm_i_filename == key) | |
321 | { | |
322 | if (SCM_NIMP (p) && SRCPROPSP (p)) | |
323 | SRCPROPCOPY (p) = datum; | |
324 | else | |
325 | SCM_WHASHSET (scm_source_whash, h, _scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); | |
326 | } | |
327 | else | |
328 | SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); | |
329 | return SCM_UNSPECIFIED; | |
330 | } | |
331 | ||
332 | #ifdef __STDC__ | |
333 | void | |
334 | scm_init_srcprop (void) | |
335 | #else | |
336 | void | |
337 | scm_init_srcprop () | |
338 | #endif | |
339 | { | |
340 | tc16_srcprops = scm_newsmob (&srcpropssmob); | |
341 | scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (255)); | |
342 | ||
343 | scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED)); | |
344 | scm_i_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED)); | |
345 | scm_i_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED)); | |
346 | scm_i_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED)); | |
347 | scm_i_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED)); | |
348 | ||
349 | scm_sysintern ("source-whash", scm_source_whash); | |
350 | #include "srcprop.x" | |
351 | } | |
352 | ||
353 | void | |
354 | scm_finish_srcprop () | |
355 | { | |
356 | register scm_srcprops_chunk *ptr = srcprops_chunklist, *next; | |
357 | while (ptr) | |
358 | { | |
359 | next = ptr->next; | |
360 | free ((char *) ptr); | |
361 | scm_mallocated -= sizeof (scm_srcprops_chunk) | |
362 | + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); | |
363 | } | |
364 | } |