libguile/mallocs.c

   1 /* classes: src_files */
   2
   3 /*      Copyright (C) 1995 Free Software Foundation, Inc.
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2, or (at your option)
   8  * any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this software; see the file COPYING.  If not, write to
  17  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18  */
  19
  20 \f
  21
  22 #include <stdio.h>
  23 #include "_scm.h"
  24 #include "genio.h"
  25 #include "smob.h"
  26
  27 #include "mallocs.h"
  28
  29 #ifdef HAVE_MALLOC_H
  30 #include <malloc.h>
  31 #endif
  32 #ifdef HAVE_UNISTD_H
  33 #include <unistd.h>
  34 #endif
  35
  36
  37 \f
  38
  39
  40 #ifdef __STDC__
  41 static scm_sizet
  42 fmalloc(SCM ptr)
  43 #else
  44 static scm_sizet
  45 fmalloc(ptr)
  46      SCM ptr;
  47 #endif
  48 {
  49   if (SCM_MALLOCDATA (ptr))
  50     free (SCM_MALLOCDATA (ptr));
  51   return 0;
  52 }
  53
  54 #ifdef __STDC__
  55 static int
  56 prinmalloc (SCM exp, SCM port, scm_print_state *pstate)
  57 #else
  58 static int
  59 prinmalloc (exp, port, pstate)
  60      SCM exp;
  61      SCM port;
  62      scm_print_state *pstate;
  63 #endif
  64 {
  65   scm_gen_puts(scm_regular_string, "#<malloc ", port);
  66   scm_intprint(SCM_CDR(exp), 16, port);
  67   scm_gen_putc('>', port);
  68   return 1;
  69 }
  70
  71 \f
  72 int scm_tc16_malloc;
  73 static scm_smobfuns mallocsmob = {scm_mark0, fmalloc, prinmalloc, 0};
  74
  75 \f
  76
  77 #ifdef __STDC__
  78 SCM
  79 scm_malloc_obj (scm_sizet n)
  80 #else
  81 SCM
  82 scm_malloc_obj (n)
  83      scm_sizet n;
  84 #endif
  85 {
  86   SCM answer;
  87   SCM mem;
  88
  89   SCM_NEWCELL (answer);
  90   SCM_DEFER_INTS;
  91   mem = (n
  92          ? (SCM)malloc (n)
  93          : 0);
  94   if (n && !mem)
  95     {
  96       SCM_ALLOW_INTS;
  97       return SCM_BOOL_F;
  98     }
  99   SCM_CDR (answer) = mem;
 100   SCM_CAR (answer) = scm_tc16_malloc;
 101   SCM_ALLOW_INTS;
 102   return answer;
 103 }
 104
 105
 106 \f
 107 #ifdef __STDC__
 108 void
 109 scm_init_mallocs (void)
 110 #else
 111 void
 112 scm_init_mallocs ()
 113 #endif
 114 {
 115   scm_tc16_malloc = scm_newsmob (&mallocsmob);
 116 }
 117