Interlisp.maiko/src/mkcell.c

/* $Id: mkcell.c,v 1.3 1999/05/31 23:35:39 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved  */
static char *id = "$Id: mkcell.c,v 1.3 1999/05/31 23:35:39 sybalsky Exp $ Copyright (C) Venue";




/************************************************************************/
/*									*/
/*	(C) Copyright 1989-95 Venue. All Rights Reserved.		*/
/*	Manufactured in the United States of America.			*/
/*									*/
/*	The contents of this file are proprietary information 		*/
/*	belonging to Venue, and are provided to you under license.	*/
/*	They may not be further distributed or disclosed to third	*/
/*	parties without the specific permission of Venue.		*/
/*									*/
/************************************************************************/

#include "version.h"


/***********************************************************************/
/*
 		File Name :	mkcell.c

		Desc	:	
 
 				Date :		Jun. 4, 1987
 				Edited by :	Takeshi Shimizu
				Changed :	9 Jun 1987 take
						26 Oct. 1987 take(add mask)
 
		Including :	OP_createcell
				
				
*/
/**********************************************************************/

#include "lispemul.h"
#include "lispmap.h"
#include "emlglob.h"
#include "lspglob.h"
#include "lsptypes.h"
#include "address.h"
#include "adr68k.h"
#include "cell.h" 
#include "gc.h" 

static LispPTR oldoldfree;
static LispPTR oldfree;
 
LispPTR *alloc_mdspage(register short int type);
LispPTR initmdspage(register LispPTR *base, register DLword size, register LispPTR prev);

LispPTR N_OP_createcell(register LispPTR tos)
{
  register struct dtd *dtd68k;
  register DLword *ptr,*lastptr;
  register LispPTR newcell ;
  register unsigned int type ;

  if((tos & SEGMASK) != S_POSITIVE) ERROR_EXIT(tos);
  type = tos & 0xffff ;

#ifdef DTDDEBUG
  if(type==TYPE_LISTP)
	error("N_OP_createcell : Can't create Listp cell with CREATECELL");
	check_dtd_chain(type);
#endif

  
  dtd68k = (struct dtd *)GetDTD(type);

  oldoldfree = oldfree;
  oldfree = dtd68k->dtd_free;

  if(dtd68k->dtd_size == 0) ERROR_EXIT(tos);
  /* error("OP_createcell : Attempt to create a cell not declared yet"); */

retry :
  if((tos=newcell=((dtd68k->dtd_free)&POINTERMASK)) != NIL)
  {
	ptr = (DLword *)Addr68k_from_LADDR(newcell);
if (917505 == *(LispPTR *)ptr) error("N_OP_createcell E0001 error");
	/* replace dtd_free with newcell's top DLword (it may keep next chain)*/
	dtd68k->dtd_free = (*((LispPTR *)ptr)) & POINTERMASK;
	if (dtd68k->dtd_free & 0x8000001) error("bad entry on free chain.");

	dtd68k->dtd_oldcnt++;

	/* clear 0  */
	for(lastptr=ptr + dtd68k->dtd_size ;
		ptr != lastptr ; ptr++)
	  {  GETWORD(ptr) = 0 ; }

/*	 IncAllocCnt(1); */
	 GCLOOKUP(tos, DELREF);
	 return(tos);
  }
  else
  {
	dtd68k->dtd_free = initmdspage(alloc_mdspage(dtd68k->dtd_typeentry) , 
				dtd68k->dtd_size ,NIL);
	if (dtd68k->dtd_free & 0x8000000) error("bad entry on free chain.");
	goto retry ;
  }

} /* N_OP_createcell end */





DLword *createcell68k(unsigned int type)
{
  register struct dtd *dtd68k;
  register DLword *ptr,*lastptr;
  register ConsCell *newcell68k;
  register LispPTR newcell ;
#ifdef DTDDEBUG
  if(type==TYPE_LISTP)
	error("createcell : Can't create Listp cell with CREATECELL");
  if(type==TYPE_STREAM) stab();

	check_dtd_chain(type);

#endif
  
  dtd68k = (struct dtd *)GetDTD(type);

  if(dtd68k->dtd_size == 0)
	error("createcell : Attempt to create a cell not declared yet");

retry :
  if((newcell=(dtd68k->dtd_free & POINTERMASK)) != NIL)
  {
#ifdef DTDDEBUG
	if(type != GetTypeNumber(newcell)) 
	  error("createcell : BAD cell in dtdfree");
	if(newcell > POINTERMASK)
		error("createcell : BAD Lisp address");
#endif

	ptr = Addr68k_from_LADDR(newcell) ;

if (917505 == *(LispPTR *)ptr) error("N_OP_createcell E0001 error");

	/* replace dtd_free with newcell's top DLword (it may keep next chain)*/
	dtd68k->dtd_free = (*((LispPTR *)ptr)) & POINTERMASK ;
	if (dtd68k->dtd_free & 0x8000000) error("bad entry on free chain.");

#ifdef DTDDEBUG
	if((dtd68k->dtd_free!=0)&&(type != GetTypeNumber(dtd68k->dtd_free)) )
	  error("createcell : BAD cell in next dtdfree");
	check_dtd_chain(type);

#endif

	dtd68k->dtd_oldcnt++;

	/* clear 0  */
	for(lastptr=ptr + dtd68k->dtd_size ;
		ptr != lastptr ; ptr++)
	  {  GETWORD(ptr) = 0 ; }

/*	IncAllocCnt(1); */
	GCLOOKUP(newcell, DELREF);

#ifdef DTDDEBUG
	check_dtd_chain(type);
#endif


	return(Addr68k_from_LADDR(newcell));
	
  }
  else
  {
	dtd68k->dtd_free = initmdspage(alloc_mdspage(dtd68k->dtd_typeentry) , 
				dtd68k->dtd_size ,NIL);
	if (dtd68k->dtd_free & 0x8000000) error("bad entry on free chain.");

#ifdef DTDDEBUG
	check_dtd_chain(type);
#endif

	goto retry ;
  }


} /* createcell68k end */


/**********************************************************/
/*  Create a Cell of Specified Type & Set to given Value  */
/*  Works with 32 bit typed values only.                  */
/*  (Initially used only by native code)                  */
/**********************************************************/

LispPTR Create_n_Set_Cell(unsigned int type, LispPTR value)
{
  register struct dtd *dtd68k;
  register DLword *ptr,*lastptr;
  register ConsCell *newcell68k;
  register LispPTR newcell ;
  
  dtd68k = (struct dtd *)GetDTD(type);

  if(dtd68k->dtd_size == 0)
	error("createcell : Attempt to create a cell not declared yet");

retry :
  if((newcell=(dtd68k->dtd_free & POINTERMASK)) != NIL)
  {
	ptr = Addr68k_from_LADDR(newcell) ;

	/* replace dtd_free with newcell's top DLword (it may keep next chain)*/

	dtd68k->dtd_free = (*((LispPTR *)ptr)) & POINTERMASK ;
	dtd68k->dtd_oldcnt++;
	if (dtd68k->dtd_free & 0x8000000) error("bad entry on free chain.");

	/* clear 0  */
	for(lastptr=ptr + dtd68k->dtd_size ;
		ptr != lastptr ; ptr++)
	  {  GETWORD(ptr) = 0 ; }

/*	IncAllocCnt(1); */
	GCLOOKUP(newcell, DELREF);
	(* ((LispPTR *) Addr68k_from_LADDR(newcell))) = value;
	return(newcell);
	
  }
  else
  {
	dtd68k->dtd_free = initmdspage(alloc_mdspage(dtd68k->dtd_typeentry) , 
				dtd68k->dtd_size ,NIL);
	if (dtd68k->dtd_free & 0x8000000) error("bad entry on free chain.");

	goto retry ;
  }


} /* createcell68k end */