1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
27 #include "libguile/_scm.h"
29 #include "libguile/objects.h"
30 #include "libguile/ports.h"
36 #include "libguile/smob.h"
40 /* scm_smobs scm_numsmob
41 * implement a fixed sized array of smob records.
42 * Indexes into this table are used when generating type
43 * tags for smobjects (if you know a tag you can get an index and conversely).
46 #define MAX_SMOB_COUNT 256
48 scm_smob_descriptor scm_smobs
[MAX_SMOB_COUNT
];
50 /* Lower 16 bit of data must be zero.
53 scm_i_set_smob_flags (SCM x
, scm_t_bits data
)
55 SCM_SET_CELL_WORD_0 (x
, (SCM_CELL_WORD_0 (x
) & 0xFFFF) | data
);
61 /* This function is vestigial. It used to be the mark function's
62 responsibility to set the mark bit on the smob or port, but now the
63 generic marking routine in gc.c takes care of that, and a zero
64 pointer for a mark function means "don't bother". So you never
67 However, we leave it here because it's harmless to call it, and
68 people out there have smob code that uses it, and there's no reason
69 to make their links fail. */
72 scm_mark0 (SCM ptr SCM_UNUSED
)
78 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
79 be used for real pairs. */
82 return SCM_CELL_OBJECT_1 (ptr
);
89 scm_free0 (SCM ptr SCM_UNUSED
)
95 scm_smob_free (SCM obj
)
97 long n
= SCM_SMOBNUM (obj
);
98 if (scm_smobs
[n
].size
> 0)
99 scm_gc_free ((void *) SCM_CELL_WORD_1 (obj
),
100 scm_smobs
[n
].size
, SCM_SMOBNAME (n
));
108 scm_smob_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
110 long n
= SCM_SMOBNUM (exp
);
111 scm_puts ("#<", port
);
112 scm_puts (SCM_SMOBNAME (n
) ? SCM_SMOBNAME (n
) : "smob", port
);
113 scm_putc (' ', port
);
114 if (scm_smobs
[n
].size
)
115 scm_intprint (SCM_CELL_WORD_1 (exp
), 16, port
);
117 scm_intprint (SCM_UNPACK (exp
), 16, port
);
118 scm_putc ('>', port
);
125 #define SCM_SMOB_APPLY0(SMOB) \
126 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
127 #define SCM_SMOB_APPLY1(SMOB, A1) \
128 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
129 #define SCM_SMOB_APPLY2(SMOB, A1, A2) \
130 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
131 #define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
132 SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
135 scm_smob_apply_0_010 (SCM smob
)
137 return SCM_SMOB_APPLY1 (smob
, SCM_UNDEFINED
);
141 scm_smob_apply_0_020 (SCM smob
)
143 return SCM_SMOB_APPLY2 (smob
, SCM_UNDEFINED
, SCM_UNDEFINED
);
147 scm_smob_apply_0_030 (SCM smob
)
149 return SCM_SMOB_APPLY3 (smob
, SCM_UNDEFINED
, SCM_UNDEFINED
, SCM_UNDEFINED
);
153 scm_smob_apply_0_001 (SCM smob
)
155 return SCM_SMOB_APPLY1 (smob
, SCM_EOL
);
159 scm_smob_apply_0_011 (SCM smob
)
161 return SCM_SMOB_APPLY2 (smob
, SCM_UNDEFINED
, SCM_EOL
);
165 scm_smob_apply_0_021 (SCM smob
)
167 return SCM_SMOB_APPLY3 (smob
, SCM_UNDEFINED
, SCM_UNDEFINED
, SCM_EOL
);
171 scm_smob_apply_0_error (SCM smob
)
173 scm_wrong_num_args (smob
);
177 scm_smob_apply_1_020 (SCM smob
, SCM a1
)
179 return SCM_SMOB_APPLY2 (smob
, a1
, SCM_UNDEFINED
);
183 scm_smob_apply_1_030 (SCM smob
, SCM a1
)
185 return SCM_SMOB_APPLY3 (smob
, a1
, SCM_UNDEFINED
, SCM_UNDEFINED
);
189 scm_smob_apply_1_001 (SCM smob
, SCM a1
)
191 return SCM_SMOB_APPLY1 (smob
, scm_list_1 (a1
));
195 scm_smob_apply_1_011 (SCM smob
, SCM a1
)
197 return SCM_SMOB_APPLY2 (smob
, a1
, SCM_EOL
);
201 scm_smob_apply_1_021 (SCM smob
, SCM a1
)
203 return SCM_SMOB_APPLY3 (smob
, a1
, SCM_UNDEFINED
, SCM_EOL
);
207 scm_smob_apply_1_error (SCM smob
, SCM a1 SCM_UNUSED
)
209 scm_wrong_num_args (smob
);
213 scm_smob_apply_2_030 (SCM smob
, SCM a1
, SCM a2
)
215 return SCM_SMOB_APPLY3 (smob
, a1
, a2
, SCM_UNDEFINED
);
219 scm_smob_apply_2_001 (SCM smob
, SCM a1
, SCM a2
)
221 return SCM_SMOB_APPLY1 (smob
, scm_list_2 (a1
, a2
));
225 scm_smob_apply_2_011 (SCM smob
, SCM a1
, SCM a2
)
227 return SCM_SMOB_APPLY2 (smob
, a1
, scm_list_1 (a2
));
231 scm_smob_apply_2_021 (SCM smob
, SCM a1
, SCM a2
)
233 return SCM_SMOB_APPLY3 (smob
, a1
, a2
, SCM_EOL
);
237 scm_smob_apply_2_error (SCM smob
, SCM a1 SCM_UNUSED
, SCM a2 SCM_UNUSED
)
239 scm_wrong_num_args (smob
);
243 scm_smob_apply_3_030 (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
245 if (!SCM_NULLP (SCM_CDR (rst
)))
246 scm_wrong_num_args (smob
);
247 return SCM_SMOB_APPLY3 (smob
, a1
, a2
, SCM_CAR (rst
));
251 scm_smob_apply_3_001 (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
253 return SCM_SMOB_APPLY1 (smob
, scm_cons2 (a1
, a2
, rst
));
257 scm_smob_apply_3_011 (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
259 return SCM_SMOB_APPLY2 (smob
, a1
, scm_cons (a2
, rst
));
263 scm_smob_apply_3_021 (SCM smob
, SCM a1
, SCM a2
, SCM rst
)
265 return SCM_SMOB_APPLY3 (smob
, a1
, a2
, rst
);
269 scm_smob_apply_3_error (SCM smob
,
274 scm_wrong_num_args (smob
);
280 scm_make_smob_type (char const *name
, size_t size
)
281 #define FUNC_NAME "scm_make_smob_type"
285 SCM_ENTER_A_SECTION
; /* scm_numsmob */
286 new_smob
= scm_numsmob
;
287 if (scm_numsmob
!= MAX_SMOB_COUNT
)
291 if (new_smob
== MAX_SMOB_COUNT
)
292 scm_misc_error (FUNC_NAME
, "maximum number of smobs exceeded", SCM_EOL
);
294 scm_smobs
[new_smob
].name
= name
;
297 scm_smobs
[new_smob
].size
= size
;
298 scm_smobs
[new_smob
].free
= scm_smob_free
;
301 /* Make a class object if Goops is present. */
303 scm_smob_class
[new_smob
] = scm_make_extended_class (name
, 0);
305 return scm_tc7_smob
+ new_smob
* 256;
311 scm_set_smob_mark (scm_t_bits tc
, SCM (*mark
) (SCM
))
313 scm_smobs
[SCM_TC2SMOBNUM (tc
)].mark
= mark
;
317 scm_set_smob_free (scm_t_bits tc
, size_t (*free
) (SCM
))
319 scm_smobs
[SCM_TC2SMOBNUM (tc
)].free
= free
;
323 scm_set_smob_print (scm_t_bits tc
, int (*print
) (SCM
, SCM
, scm_print_state
*))
325 scm_smobs
[SCM_TC2SMOBNUM (tc
)].print
= print
;
329 scm_set_smob_equalp (scm_t_bits tc
, SCM (*equalp
) (SCM
, SCM
))
331 scm_smobs
[SCM_TC2SMOBNUM (tc
)].equalp
= equalp
;
335 scm_set_smob_apply (scm_t_bits tc
, SCM (*apply
) (),
336 unsigned int req
, unsigned int opt
, unsigned int rst
)
338 SCM (*apply_0
) (SCM
);
339 SCM (*apply_1
) (SCM
, SCM
);
340 SCM (*apply_2
) (SCM
, SCM
, SCM
);
341 SCM (*apply_3
) (SCM
, SCM
, SCM
, SCM
);
342 int type
= SCM_GSUBR_MAKTYPE (req
, opt
, rst
);
344 if (rst
> 1 || req
+ opt
+ rst
> 3)
346 puts ("Unsupported smob application type");
352 case SCM_GSUBR_MAKTYPE (0, 0, 0):
353 apply_0
= apply
; break;
354 case SCM_GSUBR_MAKTYPE (0, 1, 0):
355 apply_0
= scm_smob_apply_0_010
; break;
356 case SCM_GSUBR_MAKTYPE (0, 2, 0):
357 apply_0
= scm_smob_apply_0_020
; break;
358 case SCM_GSUBR_MAKTYPE (0, 3, 0):
359 apply_0
= scm_smob_apply_0_030
; break;
360 case SCM_GSUBR_MAKTYPE (0, 0, 1):
361 apply_0
= scm_smob_apply_0_001
; break;
362 case SCM_GSUBR_MAKTYPE (0, 1, 1):
363 apply_0
= scm_smob_apply_0_011
; break;
364 case SCM_GSUBR_MAKTYPE (0, 2, 1):
365 apply_0
= scm_smob_apply_0_021
; break;
367 apply_0
= scm_smob_apply_0_error
; break;
372 case SCM_GSUBR_MAKTYPE (1, 0, 0):
373 case SCM_GSUBR_MAKTYPE (0, 1, 0):
374 apply_1
= apply
; break;
375 case SCM_GSUBR_MAKTYPE (1, 1, 0):
376 case SCM_GSUBR_MAKTYPE (0, 2, 0):
377 apply_1
= scm_smob_apply_1_020
; break;
378 case SCM_GSUBR_MAKTYPE (1, 2, 0):
379 case SCM_GSUBR_MAKTYPE (0, 3, 0):
380 apply_1
= scm_smob_apply_1_030
; break;
381 case SCM_GSUBR_MAKTYPE (0, 0, 1):
382 apply_1
= scm_smob_apply_1_001
; break;
383 case SCM_GSUBR_MAKTYPE (1, 0, 1):
384 case SCM_GSUBR_MAKTYPE (0, 1, 1):
385 apply_1
= scm_smob_apply_1_011
; break;
386 case SCM_GSUBR_MAKTYPE (1, 1, 1):
387 case SCM_GSUBR_MAKTYPE (0, 2, 1):
388 apply_1
= scm_smob_apply_1_021
; break;
390 apply_1
= scm_smob_apply_1_error
; break;
395 case SCM_GSUBR_MAKTYPE (2, 0, 0):
396 case SCM_GSUBR_MAKTYPE (1, 1, 0):
397 case SCM_GSUBR_MAKTYPE (0, 2, 0):
398 apply_2
= apply
; break;
399 case SCM_GSUBR_MAKTYPE (2, 1, 0):
400 case SCM_GSUBR_MAKTYPE (1, 2, 0):
401 case SCM_GSUBR_MAKTYPE (0, 3, 0):
402 apply_2
= scm_smob_apply_2_030
; break;
403 case SCM_GSUBR_MAKTYPE (0, 0, 1):
404 apply_2
= scm_smob_apply_2_001
; break;
405 case SCM_GSUBR_MAKTYPE (1, 0, 1):
406 case SCM_GSUBR_MAKTYPE (0, 1, 1):
407 apply_2
= scm_smob_apply_2_011
; break;
408 case SCM_GSUBR_MAKTYPE (2, 0, 1):
409 case SCM_GSUBR_MAKTYPE (1, 1, 1):
410 case SCM_GSUBR_MAKTYPE (0, 2, 1):
411 apply_2
= scm_smob_apply_2_021
; break;
413 apply_2
= scm_smob_apply_2_error
; break;
418 case SCM_GSUBR_MAKTYPE (3, 0, 0):
419 case SCM_GSUBR_MAKTYPE (2, 1, 0):
420 case SCM_GSUBR_MAKTYPE (1, 2, 0):
421 case SCM_GSUBR_MAKTYPE (0, 3, 0):
422 apply_3
= scm_smob_apply_3_030
; break;
423 case SCM_GSUBR_MAKTYPE (0, 0, 1):
424 apply_3
= scm_smob_apply_3_001
; break;
425 case SCM_GSUBR_MAKTYPE (1, 0, 1):
426 case SCM_GSUBR_MAKTYPE (0, 1, 1):
427 apply_3
= scm_smob_apply_3_011
; break;
428 case SCM_GSUBR_MAKTYPE (2, 0, 1):
429 case SCM_GSUBR_MAKTYPE (1, 1, 1):
430 case SCM_GSUBR_MAKTYPE (0, 2, 1):
431 apply_3
= scm_smob_apply_3_021
; break;
433 apply_3
= scm_smob_apply_3_error
; break;
436 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply
= apply
;
437 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_0
= apply_0
;
438 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_1
= apply_1
;
439 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_2
= apply_2
;
440 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_3
= apply_3
;
441 scm_smobs
[SCM_TC2SMOBNUM (tc
)].gsubr_type
= type
;
444 scm_i_inherit_applicable (scm_smob_class
[SCM_TC2SMOBNUM (tc
)]);
448 scm_make_smob (scm_t_bits tc
)
450 long n
= SCM_TC2SMOBNUM (tc
);
451 size_t size
= scm_smobs
[n
].size
;
452 scm_t_bits data
= (size
> 0
453 ? (scm_t_bits
) scm_gc_malloc (size
, SCM_SMOBNAME (n
))
455 return scm_cell (tc
, data
);
459 /* {Initialization for the type of free cells}
463 free_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
466 sprintf (buf
, "#<freed cell %p; GC missed a reference>",
467 (void *) SCM_UNPACK (exp
));
468 scm_puts (buf
, port
);
470 #if (SCM_DEBUG_CELL_ACCESSES == 1)
471 if (scm_debug_cell_accesses_p
)
480 scm_smob_prehistory ()
486 for (i
= 0; i
< MAX_SMOB_COUNT
; ++i
)
488 scm_smobs
[i
].name
= 0;
489 scm_smobs
[i
].size
= 0;
490 scm_smobs
[i
].mark
= 0;
491 scm_smobs
[i
].free
= 0;
492 scm_smobs
[i
].print
= scm_smob_print
;
493 scm_smobs
[i
].equalp
= 0;
494 scm_smobs
[i
].apply
= 0;
495 scm_smobs
[i
].apply_0
= 0;
496 scm_smobs
[i
].apply_1
= 0;
497 scm_smobs
[i
].apply_2
= 0;
498 scm_smobs
[i
].apply_3
= 0;
499 scm_smobs
[i
].gsubr_type
= 0;
502 /* WARNING: This scm_make_smob_type call must be done first. */
503 tc
= scm_make_smob_type ("free", 0);
504 scm_set_smob_print (tc
, free_print
);