/* classes: src_files */

/*	Copyright (C) 1995 Free Software Foundation, Inc.
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 */



#include "scm.h"
#include "setjump.h"




static sizet
fmalloc(ptr)
     SCM ptr;
{
  if (MALLOCDATA (ptr))
    free (MALLOCDATA (ptr));
  return (sizet)(CAR(ptr) >> 16);
}

static int
prinmalloc (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_lputs("#<malloc ", port);
  scm_intprint(CDR(exp), 16, port);
  scm_lputc('>', port);
  return 1;
}


static SCM
mark_root_malloc (obj)
     SCM obj;
{
  int len;
  char * mem;

  if GC8MARKP (obj)
    return BOOL_F;
  SETGC8MARK (obj);
  len = MALLOCLEN (obj);
  mem = MALLOCDATA (obj);
  scm_mark_locations ((STACKITEM *) mem, len / sizeof (STACKITEM));
  return BOOL_F;
}


static int tc16_malloc;
static int tc16_root_malloc;
static int tc16_word_smob;

static scm_smobfuns mallocsmob = {scm_mark0, fmalloc, 0, 0};
static scm_smobfuns root_mallocsmob = {mark_root_malloc, fmalloc, 0, 0};
static scm_smobfuns word_smob = {scm_mark0, scm_free0, 0, 0};



SCM
scm_malloc_obj (n)
     sizet n;
{
  SCM answer;
  SCM mem;
  NEWCELL (answer);
  mem = (SCM)scm_must_malloc (n, "create a malloc object.");
  DEFER_INTS;
  CDR (answer) = mem;
  CAR (answer) = (SCM)((n << 16) | tc16_malloc);
  ALLOW_INTS;
  return answer;
}


SCM
scm_word_obj (init)
     long init;
{
  SCM answer;
  NEWCELL (answer);
  DEFER_INTS;
  CDR (answer) = (SCM)init;
  CAR (answer) = (SCM)tc16_word_smob;
  ALLOW_INTS;
  return answer;
}


SCM
scm_malloc_root_obj (n)
     sizet n;
{
  SCM answer;
  SCM mem;
  NEWCELL (answer);
  mem = (SCM)scm_must_malloc (n, "create a root malloc object.");
  DEFER_INTS;
  CDR (answer) = mem;
  CAR (answer) = (SCM)((n << 16) | tc16_root_malloc);
  ALLOW_INTS;
  return answer;
}


SCM
scm_realloc_obj (answer, n)
     sizet n;
{
  SCM mem;
  mem = (SCM)scm_must_realloc (MALLOCDATA (answer), MALLOCLEN(answer),
			       n, "realloc a malloc object.");
  DEFER_INTS;
  CDR (answer) = mem;
  CAR (answer) = (SCM)((n << 16) | TYP16 (answer));
  ALLOW_INTS;
  return answer;
}

SCM
scm_free_malloc_obj (o)
{
  DEFER_INTS;
  if (MALLOCDATA (o))
    {
      free (MALLOCDATA (o));
      MALLOCDATA (o) = 0;
    }
  ALLOW_INTS;
}




void 
scm_init_mallocs ()
{
  tc16_malloc = scm_newsmob (&mallocsmob);
  tc16_root_malloc = scm_newsmob (&root_mallocsmob);
  tc16_word_smob = scm_newsmob (&word_smob);
}

