bb4f99b100ac9c8dbc8baf7f554d3a045c05c35a
1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc.
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)
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.
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, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
61 /* scm_smobs scm_numsmob
62 * implement a dynamicly resized array of smob records.
63 * Indexes into this table are used when generating type
64 * tags for smobjects (if you know a tag you can get an index and conversely).
67 scm_smob_descriptor
*scm_smobs
;
72 /* This function is vestigial. It used to be the mark function's
73 responsibility to set the mark bit on the smob or port, but now the
74 generic marking routine in gc.c takes care of that, and a zero
75 pointer for a mark function means "don't bother". So you never
78 However, we leave it here because it's harmless to call it, and
79 people out there have smob code that uses it, and there's no reason
80 to make their links fail. */
104 scm_smob_free (SCM obj
)
106 scm_must_free ((char *) SCM_CDR (obj
));
107 return scm_smobs
[SCM_SMOBNUM (obj
)].size
;
114 scm_smob_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
116 int n
= SCM_SMOBNUM (exp
);
117 scm_puts ("#<", port
);
118 scm_puts (SCM_SMOBNAME (n
) ? SCM_SMOBNAME (n
) : "smob", port
);
119 scm_putc (' ', port
);
120 scm_intprint (SCM_UNPACK (scm_smobs
[n
].size
? SCM_CDR (exp
) : exp
), 16, port
);
121 scm_putc ('>', port
);
126 scm_make_smob_type (char *name
, scm_sizet size
)
129 if (255 <= scm_numsmob
)
132 SCM_SYSCALL (tmp
= (char *) realloc ((char *) scm_smobs
,
134 * sizeof (scm_smob_descriptor
)));
137 scm_smobs
= (scm_smob_descriptor
*) tmp
;
138 scm_smobs
[scm_numsmob
].name
= name
;
139 scm_smobs
[scm_numsmob
].size
= size
;
140 scm_smobs
[scm_numsmob
].mark
= 0;
141 scm_smobs
[scm_numsmob
].free
= (size
== 0 ? scm_free0
: scm_smob_free
);
142 scm_smobs
[scm_numsmob
].print
= scm_smob_print
;
143 scm_smobs
[scm_numsmob
].equalp
= 0;
148 smoberr
:scm_wta (SCM_MAKINUM ((long) scm_numsmob
),
149 (char *) SCM_NALLOC
, "scm_make_smob_type");
150 /* Make a class object if Goops is present. */
152 scm_smob_class
[scm_numsmob
- 1]
153 = scm_make_extended_class (SCM_SMOBNAME (scm_numsmob
- 1));
154 return scm_tc7_smob
+ (scm_numsmob
- 1) * 256;
158 scm_make_smob_type_mfpe (char *name
, scm_sizet size
,
160 scm_sizet (*free
) (SCM
),
161 int (*print
) (SCM
, SCM
, scm_print_state
*),
162 SCM (*equalp
) (SCM
, SCM
))
164 long answer
= scm_make_smob_type (name
, size
);
165 scm_set_smob_mfpe (answer
, mark
, free
, print
, equalp
);
170 scm_set_smob_mark (long tc
, SCM (*mark
) (SCM
))
172 scm_smobs
[SCM_TC2SMOBNUM (tc
)].mark
= mark
;
176 scm_set_smob_free (long tc
, scm_sizet (*free
) (SCM
))
178 scm_smobs
[SCM_TC2SMOBNUM (tc
)].free
= free
;
182 scm_set_smob_print (long tc
, int (*print
) (SCM
, SCM
, scm_print_state
*))
184 scm_smobs
[SCM_TC2SMOBNUM (tc
)].print
= print
;
188 scm_set_smob_equalp (long tc
, SCM (*equalp
) (SCM
, SCM
))
190 scm_smobs
[SCM_TC2SMOBNUM (tc
)].equalp
= equalp
;
194 scm_set_smob_mfpe (long tc
,
196 scm_sizet (*free
) (SCM
),
197 int (*print
) (SCM
, SCM
, scm_print_state
*),
198 SCM (*equalp
) (SCM
, SCM
))
200 if (mark
) scm_set_smob_mark (tc
, mark
);
201 if (free
) scm_set_smob_free (tc
, free
);
202 if (print
) scm_set_smob_print (tc
, print
);
203 if (equalp
) scm_set_smob_equalp (tc
, equalp
);
206 /* Deprecated function - use scm_make_smob_type, or scm_make_smob_type_mfpe
209 scm_newsmob (const scm_smobfuns
*smob
)
211 long tc
= scm_make_smob_type (0, 0);
212 scm_set_smob_mark (tc
, smob
->mark
);
213 scm_set_smob_free (tc
, smob
->free
);
214 scm_set_smob_print (tc
, smob
->print
);
215 scm_set_smob_equalp (tc
, smob
->equalp
);
221 scm_make_smob (long tc
)
223 int n
= SCM_TC2SMOBNUM (tc
);
224 scm_sizet size
= scm_smobs
[n
].size
;
230 SCM_ASSERT (scm_smobs
[n
].mark
== 0,
232 "forbidden operation for smobs with GC data, use SCM_NEWSMOB",
235 SCM_SET_SMOB_DATA (z
, scm_must_malloc (size
, SCM_SMOBNAME (n
)));
242 /* {Initialization for i/o types, float, bignum, the type of free cells}
248 scm_print_state
*pstate
)
252 sprintf (buf
, "#<freed cell %p; GC missed a reference>", (void *) exp
);
253 scm_puts (buf
, port
);
260 scm_smob_prehistory ()
263 scm_smobs
= ((scm_smob_descriptor
*)
264 malloc (7 * sizeof (scm_smob_descriptor
)));
266 /* WARNING: These scm_make_smob_type calls must be done in this order */
267 scm_make_smob_type_mfpe ("free", 0,
268 NULL
, NULL
, freeprint
, NULL
);
270 scm_make_smob_type_mfpe ("big", 0, /* freed in gc */
271 NULL
, NULL
, scm_bigprint
, scm_bigequal
);
273 scm_make_smob_type_mfpe ("real", 0, /* freed in gc */
274 NULL
, NULL
, scm_print_real
, scm_real_equalp
);
276 scm_make_smob_type_mfpe ("complex", 0, /* freed in gc */
277 NULL
, NULL
, scm_print_complex
, scm_complex_equalp
);
279 scm_make_smob_type ("allocated", 0);