libguile/mallocs.c

   1 /* classes: src_files
   2  * Copyright (C) 1995,1997,1998,2000,2001, 2006, 2011,
   3  *   2014 Free Software Foundation, Inc.
   4  *
   5  * This library is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU Lesser General Public License
   7  * as published by the Free Software Foundation; either version 3 of
   8  * the License, or (at your option) any later version.
   9  *
  10  * This library is distributed in the hope that it will be useful, but
  11  * WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18  * 02110-1301 USA
  19  */
  20
  21
  22
  23 \f
  24 #ifdef HAVE_CONFIG_H
  25 #  include <config.h>
  26 #endif
  27
  28 #include <stdlib.h>
  29
  30 #include "libguile/_scm.h"
  31 #include "libguile/ports.h"
  32 #include "libguile/smob.h"
  33
  34 #include "libguile/mallocs.h"
  35
  36 #include <unistd.h>
  37
  38
  39 \f
  40 scm_t_bits scm_tc16_malloc;
  41
  42
  43
  44 static int
  45 malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  46 {
  47   scm_puts_unlocked("#<malloc ", port);
  48   scm_uintprint (SCM_SMOB_DATA (exp), 16, port);
  49   scm_putc_unlocked('>', port);
  50   return 1;
  51 }
  52
  53 \f
  54 SCM
  55 scm_malloc_obj (size_t n)
  56 {
  57   scm_t_bits mem = n ? (scm_t_bits) scm_gc_malloc (n, "malloc smob") : 0;
  58   if (n && !mem)
  59     return SCM_BOOL_F;
  60   SCM_RETURN_NEWSMOB (scm_tc16_malloc, mem);
  61 }
  62
  63
  64 \f
  65 void
  66 scm_init_mallocs ()
  67 {
  68   scm_tc16_malloc = scm_make_smob_type ("malloc", 0);
  69   scm_set_smob_print (scm_tc16_malloc, malloc_print);
  70 }
  71
  72 /*
  73   Local Variables:
  74   c-file-style: "gnu"
  75   End:
  76 */