Commit | Line | Data |
---|---|---|
7dc6e754 | 1 | /* Copyright (C) 1995,1996,1998 Free Software Foundation, Inc. |
0f2d19dd JB |
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 | |
0f2d19dd JB |
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. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
0f2d19dd JB |
41 | \f |
42 | ||
43 | #include <stdio.h> | |
44 | #include "_scm.h" | |
20e6290e | 45 | |
d7ec6b9f | 46 | #include "objects.h" |
9dd5943c | 47 | #include "genio.h" |
d7ec6b9f | 48 | |
0f2d19dd JB |
49 | #ifdef HAVE_MALLOC_H |
50 | #include <malloc.h> | |
51 | #endif | |
52 | ||
9dd5943c MD |
53 | #include "smob.h" |
54 | ||
0f2d19dd JB |
55 | \f |
56 | ||
57 | /* scm_smobs scm_numsmob | |
58 | * implement a dynamicly resized array of smob records. | |
59 | * Indexes into this table are used when generating type | |
60 | * tags for smobjects (if you know a tag you can get an index and conversely). | |
61 | */ | |
4e6e2119 | 62 | int scm_numsmob; |
9dd5943c | 63 | scm_smob_descriptor *scm_smobs; |
0f2d19dd | 64 | |
9dd5943c MD |
65 | /* {Mark} |
66 | */ | |
67 | ||
68 | /* This function is vestigial. It used to be the mark function's | |
69 | responsibility to set the mark bit on the smob or port, but now the | |
70 | generic marking routine in gc.c takes care of that, and a zero | |
71 | pointer for a mark function means "don't bother". So you never | |
72 | need scm_mark0. | |
73 | ||
74 | However, we leave it here because it's harmless to call it, and | |
75 | people out there have smob code that uses it, and there's no reason | |
76 | to make their links fail. */ | |
77 | ||
78 | SCM | |
79 | scm_mark0 (ptr) | |
80 | SCM ptr; | |
81 | { | |
82 | return SCM_BOOL_F; | |
83 | } | |
84 | ||
85 | SCM | |
86 | scm_markcdr (ptr) | |
87 | SCM ptr; | |
88 | { | |
89 | return SCM_CDR (ptr); | |
90 | } | |
91 | ||
92 | /* {Free} | |
93 | */ | |
94 | ||
95 | scm_sizet | |
96 | scm_free0 (ptr) | |
97 | SCM ptr; | |
98 | { | |
99 | return 0; | |
100 | } | |
101 | ||
102 | scm_sizet | |
103 | scm_smob_free (SCM obj) | |
104 | { | |
105 | scm_must_free ((char *) SCM_CDR (obj)); | |
106 | return scm_smobs[SCM_SMOBNUM (obj)].size; | |
107 | } | |
108 | ||
109 | /* {Print} | |
110 | */ | |
111 | ||
112 | int | |
113 | scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) | |
114 | { | |
115 | int n = SCM_SMOBNUM (exp); | |
116 | scm_puts ("#<", port); | |
117 | scm_puts (SCM_SMOBNAME (n), port); | |
118 | scm_putc (' ', port); | |
119 | scm_intprint (scm_smobs[n].size ? SCM_CDR (exp) : exp, 16, port); | |
120 | scm_putc ('>', port); | |
121 | return 1; | |
122 | } | |
1cc91f1b | 123 | |
0f2d19dd | 124 | long |
9dd5943c | 125 | scm_make_smob_type (char *name, scm_sizet size) |
0f2d19dd JB |
126 | { |
127 | char *tmp; | |
128 | if (255 <= scm_numsmob) | |
129 | goto smoberr; | |
130 | SCM_DEFER_INTS; | |
9dd5943c MD |
131 | SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_smobs, |
132 | (1 + scm_numsmob) | |
133 | * sizeof (scm_smob_descriptor))); | |
0f2d19dd JB |
134 | if (tmp) |
135 | { | |
9dd5943c MD |
136 | scm_smobs = (scm_smob_descriptor *) tmp; |
137 | scm_smobs[scm_numsmob].name = name; | |
138 | scm_smobs[scm_numsmob].size = size; | |
139 | scm_smobs[scm_numsmob].mark = 0; | |
140 | scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free); | |
141 | scm_smobs[scm_numsmob].print = scm_smob_print; | |
142 | scm_smobs[scm_numsmob].equalp = 0; | |
0f2d19dd JB |
143 | scm_numsmob++; |
144 | } | |
145 | SCM_ALLOW_INTS; | |
146 | if (!tmp) | |
9dd5943c MD |
147 | smoberr:scm_wta (SCM_MAKINUM ((long) scm_numsmob), |
148 | (char *) SCM_NALLOC, "scm_make_smob_type"); | |
d7ec6b9f MD |
149 | /* Make a class object if Goops is present. */ |
150 | if (scm_smob_class) | |
151 | scm_smob_class[scm_numsmob - 1] | |
152 | = scm_make_extended_class (SCM_SMOBNAME (scm_numsmob - 1)); | |
0f2d19dd JB |
153 | return scm_tc7_smob + (scm_numsmob - 1) * 256; |
154 | } | |
155 | ||
23a62151 MD |
156 | long |
157 | scm_make_smob_type_mfpe (char *name, scm_sizet size, | |
158 | SCM (*mark) (SCM), | |
159 | scm_sizet (*free) (SCM), | |
160 | int (*print) (SCM, SCM, scm_print_state *), | |
161 | SCM (*equalp) (SCM, SCM)) | |
162 | { | |
163 | long answer = scm_make_smob_type (name, size); | |
164 | scm_set_smob_mfpe (answer, mark, free, print, equalp); | |
165 | return answer; | |
166 | } | |
167 | ||
9dd5943c MD |
168 | void |
169 | scm_set_smob_mark (long tc, SCM (*mark) (SCM)) | |
170 | { | |
171 | scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark; | |
172 | } | |
173 | ||
174 | void | |
175 | scm_set_smob_free (long tc, scm_sizet (*free) (SCM)) | |
176 | { | |
177 | scm_smobs[SCM_TC2SMOBNUM (tc)].free = free; | |
178 | } | |
179 | ||
180 | void | |
181 | scm_set_smob_print (long tc, int (*print) (SCM, SCM, scm_print_state*)) | |
182 | { | |
183 | scm_smobs[SCM_TC2SMOBNUM (tc)].print = print; | |
184 | } | |
185 | ||
186 | void | |
187 | scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM)) | |
188 | { | |
189 | scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp; | |
190 | } | |
191 | ||
23a62151 MD |
192 | void |
193 | scm_set_smob_mfpe (long tc, | |
194 | SCM (*mark) (SCM), | |
195 | scm_sizet (*free) (SCM), | |
196 | int (*print) (SCM, SCM, scm_print_state *), | |
197 | SCM (*equalp) (SCM, SCM)) | |
198 | { | |
199 | if (mark) scm_set_smob_mark (tc, mark); | |
200 | if (free) scm_set_smob_free (tc, free); | |
201 | if (print) scm_set_smob_print (tc, print); | |
202 | if (equalp) scm_set_smob_equalp (tc, equalp); | |
203 | } | |
204 | ||
205 | /* Deprecated function - use scm_make_smob_type, or scm_make_smob_type_mfpe | |
206 | instead. */ | |
9dd5943c MD |
207 | long |
208 | scm_newsmob (const scm_smobfuns *smob) | |
209 | { | |
210 | long tc = scm_make_smob_type (0, 0); | |
211 | scm_set_smob_mark (tc, smob->mark); | |
212 | scm_set_smob_free (tc, smob->free); | |
213 | scm_set_smob_print (tc, smob->print); | |
214 | scm_set_smob_equalp (tc, smob->equalp); | |
215 | return tc; | |
216 | } | |
217 | ||
218 | ||
219 | SCM | |
220 | scm_make_smob (long tc) | |
221 | { | |
222 | int n = SCM_TC2SMOBNUM (tc); | |
223 | scm_sizet size = scm_smobs[n].size; | |
224 | SCM z; | |
225 | SCM_NEWCELL (z); | |
226 | if (size != 0) | |
227 | { | |
228 | #if 0 | |
229 | SCM_ASSERT (scm_smobs[n].mark == 0, | |
230 | 0, | |
231 | "forbidden operation for smobs with GC data, use SCM_NEWSMOB", | |
232 | SCM_SMOBNAME (n)); | |
233 | #endif | |
234 | SCM_SET_SMOB_DATA (z, scm_must_malloc (size, SCM_SMOBNAME (n))); | |
235 | } | |
236 | SCM_SETCAR (z, tc); | |
237 | return z; | |
238 | } | |
239 | ||
ceef3208 | 240 | \f |
0f2d19dd JB |
241 | /* {Initialization for i/o types, float, bignum, the type of free cells} |
242 | */ | |
243 | ||
ceef3208 JB |
244 | static int |
245 | freeprint (SCM exp, | |
246 | SCM port, | |
247 | scm_print_state *pstate) | |
248 | { | |
249 | char buf[100]; | |
250 | ||
251 | sprintf (buf, "#<freed cell %p; GC missed a reference>", (void *) exp); | |
252 | scm_puts (buf, port); | |
253 | ||
254 | return 1; | |
255 | } | |
256 | ||
257 | ||
0f2d19dd JB |
258 | void |
259 | scm_smob_prehistory () | |
0f2d19dd JB |
260 | { |
261 | scm_numsmob = 0; | |
9dd5943c MD |
262 | scm_smobs = ((scm_smob_descriptor *) |
263 | malloc (7 * sizeof (scm_smob_descriptor))); | |
264 | ||
265 | /* WARNING: These scm_make_smob_type calls must be done in this order */ | |
23a62151 MD |
266 | scm_make_smob_type_mfpe ("free", 0, |
267 | NULL, NULL, freeprint, NULL); | |
268 | ||
269 | scm_make_smob_type_mfpe ("flo", 0, /* freed in gc */ | |
270 | NULL, NULL, scm_floprint, scm_floequal); | |
271 | ||
272 | scm_make_smob_type_mfpe ("bigpos", 0, /* freed in gc */ | |
273 | NULL, NULL, scm_bigprint, scm_bigequal); | |
274 | ||
275 | scm_make_smob_type_mfpe ("bigneg", 0, | |
276 | NULL, NULL, scm_bigprint, scm_bigequal); | |
0f2d19dd | 277 | } |