ca23373bbd288e4ebce044b8b18386bccae4ec79
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 */
48 #include "libguile/_scm.h"
50 #include "libguile/objects.h"
51 #include "libguile/ports.h"
57 #include "libguile/smob.h"
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_CELL_WORD_1 (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
);
128 #define SCM_SMOB_APPLY0(SMOB) \
129 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
130 #define SCM_SMOB_APPLY1(SMOB,A1) \
131 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
132 #define SCM_SMOB_APPLY2(SMOB,A1,A2) \
133 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
134 #define SCM_SMOB_APPLY3(SMOB,A1,A2,A3) \
135 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
138 scm_smob_apply_0_000 (SCM smob
)
140 return SCM_SMOB_APPLY0 (smob
);
144 scm_smob_apply_0_010 (SCM smob
)
146 return SCM_SMOB_APPLY1 (smob
, SCM_UNDEFINED
);
150 scm_smob_apply_0_020 (SCM smob
)
152 return SCM_SMOB_APPLY2 (smob
, SCM_UNDEFINED
, SCM_UNDEFINED
);
156 scm_smob_apply_0_030 (SCM smob
)
158 return SCM_SMOB_APPLY3 (smob
, SCM_UNDEFINED
, SCM_UNDEFINED
, SCM_UNDEFINED
);
162 scm_smob_apply_0_001 (SCM smob
)
164 return SCM_SMOB_APPLY1 (smob
, SCM_EOL
);
168 scm_smob_apply_0_011 (SCM smob
)
170 return SCM_SMOB_APPLY2 (smob
, SCM_UNDEFINED
, SCM_EOL
);
174 scm_smob_apply_0_021 (SCM smob
)
176 return SCM_SMOB_APPLY3 (smob
, SCM_UNDEFINED
, SCM_UNDEFINED
, SCM_EOL
);
180 scm_smob_apply_0_error (SCM smob
)
182 scm_wrong_num_args (smob
);
186 scm_smob_apply_1_010 (SCM smob
, SCM a1
)
188 return SCM_SMOB_APPLY1 (smob
, a1
);
192 scm_smob_apply_1_020 (SCM smob
, SCM a1
)
194 return SCM_SMOB_APPLY2 (smob
, a1
, SCM_UNDEFINED
);
198 scm_smob_apply_1_030 (SCM smob
, SCM a1
)
200 return SCM_SMOB_APPLY3 (smob
, a1
, SCM_UNDEFINED
, SCM_UNDEFINED
);
204 scm_smob_apply_1_001 (SCM smob
, SCM a1
)
206 return SCM_SMOB_APPLY1 (smob
, SCM_LIST1 (a1
));
210 scm_smob_apply_1_011 (SCM smob
, SCM a1
)
212 return SCM_SMOB_APPLY2 (smob
, a1
, SCM_EOL
);
216 scm_smob_apply_1_021 (SCM smob
, SCM a1
)
218 return SCM_SMOB_APPLY3 (smob
, a1
, SCM_UNDEFINED
, SCM_EOL
);
222 scm_smob_apply_1_error (SCM smob
, SCM a1
)
224 scm_wrong_num_args (smob
);
228 scm_smob_apply_2_020 (SCM smob
, SCM a1
, SCM a2
)
230 return SCM_SMOB_APPLY2 (smob
, a1
, a2
);
234 scm_smob_apply_2_030 (SCM smob
, SCM a1
, SCM a2
)
236 return SCM_SMOB_APPLY3 (smob
, a1
, a2
, SCM_UNDEFINED
);
240 scm_smob_apply_2_001 (SCM smob
, SCM a1
, SCM a2
)
242 return SCM_SMOB_APPLY1 (smob
, SCM_LIST2 (a1
, a2
));
246 scm_smob_apply_2_011 (SCM smob
, SCM a1
, SCM a2
)
248 return SCM_SMOB_APPLY2 (smob
, a1
, SCM_LIST1 (a2
));
252 scm_smob_apply_2_021 (SCM smob
, SCM a1
, SCM a2
)
254 return SCM_SMOB_APPLY3 (smob
, a1
, a2
, SCM_EOL
);
258 scm_smob_apply_2_error (SCM smob
, SCM a1
, SCM a2
)
260 scm_wrong_num_args (smob
);
264 scm_smob_apply_3_030 (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
266 if (!SCM_NULLP (SCM_CDR (rst
)))
267 scm_wrong_num_args (smob
);
268 return SCM_SMOB_APPLY3 (smob
, a1
, a2
, SCM_CAR (rst
));
272 scm_smob_apply_3_001 (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
274 return SCM_SMOB_APPLY1 (smob
, scm_cons2 (a1
, a2
, rst
));
278 scm_smob_apply_3_011 (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
280 return SCM_SMOB_APPLY2 (smob
, a1
, scm_cons (a2
, rst
));
284 scm_smob_apply_3_021 (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
286 return SCM_SMOB_APPLY3 (smob
, a1
, a2
, rst
);
290 scm_smob_apply_3_error (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
292 scm_wrong_num_args (smob
);
297 scm_make_smob_type (char *name
, scm_sizet size
)
300 if (255 <= scm_numsmob
)
303 SCM_SYSCALL (tmp
= (char *) realloc ((char *) scm_smobs
,
305 * sizeof (scm_smob_descriptor
)));
308 scm_smobs
= (scm_smob_descriptor
*) tmp
;
309 scm_smobs
[scm_numsmob
].name
= name
;
310 scm_smobs
[scm_numsmob
].size
= size
;
311 scm_smobs
[scm_numsmob
].mark
= 0;
312 scm_smobs
[scm_numsmob
].free
= (size
== 0 ? scm_free0
: scm_smob_free
);
313 scm_smobs
[scm_numsmob
].print
= scm_smob_print
;
314 scm_smobs
[scm_numsmob
].equalp
= 0;
315 scm_smobs
[scm_numsmob
].apply
= 0;
316 scm_smobs
[scm_numsmob
].apply_0
= 0;
317 scm_smobs
[scm_numsmob
].apply_1
= 0;
318 scm_smobs
[scm_numsmob
].apply_2
= 0;
319 scm_smobs
[scm_numsmob
].apply_3
= 0;
320 scm_smobs
[scm_numsmob
].gsubr_type
= 0;
327 scm_memory_error ("scm_make_smob_type");
329 /* Make a class object if Goops is present. */
331 scm_smob_class
[scm_numsmob
- 1]
332 = scm_make_extended_class (SCM_SMOBNAME (scm_numsmob
- 1));
333 return scm_tc7_smob
+ (scm_numsmob
- 1) * 256;
337 scm_make_smob_type_mfpe (char *name
, scm_sizet size
,
339 scm_sizet (*free
) (SCM
),
340 int (*print
) (SCM
, SCM
, scm_print_state
*),
341 SCM (*equalp
) (SCM
, SCM
))
343 long answer
= scm_make_smob_type (name
, size
);
344 scm_set_smob_mfpe (answer
, mark
, free
, print
, equalp
);
349 scm_set_smob_mark (long tc
, SCM (*mark
) (SCM
))
351 scm_smobs
[SCM_TC2SMOBNUM (tc
)].mark
= mark
;
355 scm_set_smob_free (long tc
, scm_sizet (*free
) (SCM
))
357 scm_smobs
[SCM_TC2SMOBNUM (tc
)].free
= free
;
361 scm_set_smob_print (long tc
, int (*print
) (SCM
, SCM
, scm_print_state
*))
363 scm_smobs
[SCM_TC2SMOBNUM (tc
)].print
= print
;
367 scm_set_smob_equalp (long tc
, SCM (*equalp
) (SCM
, SCM
))
369 scm_smobs
[SCM_TC2SMOBNUM (tc
)].equalp
= equalp
;
373 scm_set_smob_apply (long tc
, SCM (*apply
) (), int req
, int opt
, int rst
)
375 SCM (*apply_0
) (SCM
);
376 SCM (*apply_1
) (SCM
, SCM
);
377 SCM (*apply_2
) (SCM
, SCM
, SCM
);
378 SCM (*apply_3
) (SCM
, SCM
, SCM
, SCM
);
379 int type
= SCM_GSUBR_MAKTYPE (req
, opt
, rst
);
381 if (!(req
>= 0 && opt
>= 0 && (rst
== 0 || rst
== 1)
382 && req
+ opt
+ rst
<= 3))
384 puts ("Unsupported smob application type");
390 case SCM_GSUBR_MAKTYPE (0, 0, 0):
391 apply_0
= scm_smob_apply_0_000
; break;
392 case SCM_GSUBR_MAKTYPE (0, 1, 0):
393 apply_0
= scm_smob_apply_0_010
; break;
394 case SCM_GSUBR_MAKTYPE (0, 2, 0):
395 apply_0
= scm_smob_apply_0_020
; break;
396 case SCM_GSUBR_MAKTYPE (0, 3, 0):
397 apply_0
= scm_smob_apply_0_030
; break;
398 case SCM_GSUBR_MAKTYPE (0, 0, 1):
399 apply_0
= scm_smob_apply_0_001
; break;
400 case SCM_GSUBR_MAKTYPE (0, 1, 1):
401 apply_0
= scm_smob_apply_0_011
; break;
402 case SCM_GSUBR_MAKTYPE (0, 2, 1):
403 apply_0
= scm_smob_apply_0_021
; break;
405 apply_0
= scm_smob_apply_0_error
; break;
410 case SCM_GSUBR_MAKTYPE (1, 0, 0):
411 case SCM_GSUBR_MAKTYPE (0, 1, 0):
412 apply_1
= scm_smob_apply_1_010
; break;
413 case SCM_GSUBR_MAKTYPE (1, 1, 0):
414 case SCM_GSUBR_MAKTYPE (0, 2, 0):
415 apply_1
= scm_smob_apply_1_020
; break;
416 case SCM_GSUBR_MAKTYPE (1, 2, 0):
417 case SCM_GSUBR_MAKTYPE (0, 3, 0):
418 apply_1
= scm_smob_apply_1_030
; break;
419 case SCM_GSUBR_MAKTYPE (0, 0, 1):
420 apply_1
= scm_smob_apply_1_001
; break;
421 case SCM_GSUBR_MAKTYPE (1, 0, 1):
422 case SCM_GSUBR_MAKTYPE (0, 1, 1):
423 apply_1
= scm_smob_apply_1_011
; break;
424 case SCM_GSUBR_MAKTYPE (1, 1, 1):
425 case SCM_GSUBR_MAKTYPE (0, 2, 1):
426 apply_1
= scm_smob_apply_1_021
; break;
428 apply_1
= scm_smob_apply_1_error
; break;
433 case SCM_GSUBR_MAKTYPE (2, 0, 0):
434 case SCM_GSUBR_MAKTYPE (1, 1, 0):
435 case SCM_GSUBR_MAKTYPE (0, 2, 0):
436 apply_2
= scm_smob_apply_2_020
; break;
437 case SCM_GSUBR_MAKTYPE (2, 1, 0):
438 case SCM_GSUBR_MAKTYPE (1, 2, 0):
439 case SCM_GSUBR_MAKTYPE (0, 3, 0):
440 apply_2
= scm_smob_apply_2_030
; break;
441 case SCM_GSUBR_MAKTYPE (0, 0, 1):
442 apply_2
= scm_smob_apply_2_001
; break;
443 case SCM_GSUBR_MAKTYPE (1, 0, 1):
444 case SCM_GSUBR_MAKTYPE (0, 1, 1):
445 apply_2
= scm_smob_apply_2_011
; break;
446 case SCM_GSUBR_MAKTYPE (2, 0, 1):
447 case SCM_GSUBR_MAKTYPE (1, 1, 1):
448 case SCM_GSUBR_MAKTYPE (0, 2, 1):
449 apply_2
= scm_smob_apply_2_021
; break;
451 apply_2
= scm_smob_apply_2_error
; break;
456 case SCM_GSUBR_MAKTYPE (3, 0, 0):
457 case SCM_GSUBR_MAKTYPE (2, 1, 0):
458 case SCM_GSUBR_MAKTYPE (1, 2, 0):
459 case SCM_GSUBR_MAKTYPE (0, 3, 0):
460 apply_3
= scm_smob_apply_3_030
; break;
461 case SCM_GSUBR_MAKTYPE (0, 0, 1):
462 apply_3
= scm_smob_apply_3_001
; break;
463 case SCM_GSUBR_MAKTYPE (1, 0, 1):
464 case SCM_GSUBR_MAKTYPE (0, 1, 1):
465 apply_3
= scm_smob_apply_3_011
; break;
466 case SCM_GSUBR_MAKTYPE (2, 0, 1):
467 case SCM_GSUBR_MAKTYPE (1, 1, 1):
468 case SCM_GSUBR_MAKTYPE (0, 2, 1):
469 apply_3
= scm_smob_apply_3_021
; break;
471 apply_3
= scm_smob_apply_3_error
; break;
474 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply
= apply
;
475 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_0
= apply_0
;
476 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_1
= apply_1
;
477 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_2
= apply_2
;
478 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_3
= apply_3
;
479 scm_smobs
[SCM_TC2SMOBNUM (tc
)].gsubr_type
= type
;
483 scm_set_smob_mfpe (long tc
,
485 scm_sizet (*free
) (SCM
),
486 int (*print
) (SCM
, SCM
, scm_print_state
*),
487 SCM (*equalp
) (SCM
, SCM
))
489 if (mark
) scm_set_smob_mark (tc
, mark
);
490 if (free
) scm_set_smob_free (tc
, free
);
491 if (print
) scm_set_smob_print (tc
, print
);
492 if (equalp
) scm_set_smob_equalp (tc
, equalp
);
497 scm_make_smob (long tc
)
499 int n
= SCM_TC2SMOBNUM (tc
);
500 scm_sizet size
= scm_smobs
[n
].size
;
506 SCM_ASSERT (scm_smobs
[n
].mark
== 0,
508 "forbidden operation for smobs with GC data, use SCM_NEWSMOB",
511 SCM_SET_SMOB_DATA (z
, scm_must_malloc (size
, SCM_SMOBNAME (n
)));
513 SCM_SET_CELL_TYPE (z
, tc
);
518 /* {Initialization for i/o types, float, bignum, the type of free cells}
524 scm_print_state
*pstate
)
528 sprintf (buf
, "#<freed cell %p; GC missed a reference>", (void *) SCM_UNPACK (exp
));
529 scm_puts (buf
, port
);
536 scm_smob_prehistory ()
539 scm_smobs
= ((scm_smob_descriptor
*)
540 malloc (7 * sizeof (scm_smob_descriptor
)));
542 /* WARNING: These scm_make_smob_type calls must be done in this order */
543 scm_make_smob_type_mfpe ("free", 0,
544 NULL
, NULL
, freeprint
, NULL
);
546 scm_make_smob_type_mfpe ("big", 0, /* freed in gc */
547 NULL
, NULL
, scm_bigprint
, scm_bigequal
);
549 scm_make_smob_type_mfpe ("real", 0, /* freed in gc */
550 NULL
, NULL
, scm_print_real
, scm_real_equalp
);
552 scm_make_smob_type_mfpe ("complex", 0, /* freed in gc */
553 NULL
, NULL
, scm_print_complex
, scm_complex_equalp
);