view release on metacpan or  search on metacpan

sliba.c  view on Meta::CPAN

/*  
 *                   COPYRIGHT (c) 1988-1996 BY                             *
 *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
 *        See the source file SLIB.C for more information.                  *

Array-hacking code moved to another source file.

*/

#include <stdio.h>
#include <string.h>
#include <setjmp.h>
#include <stdlib.h>
#include <stdarg.h>
#include <ctype.h>
#include <math.h>

#include "siod.h"
#include "siodp.h"

static void init_sliba_version(void)
{setvar(cintern("*sliba-version*"),
	cintern("$Id: sliba.c,v 1.1.1.1 2000/12/09 01:57:11 thhsieh Exp $"),
	NIL);}

static LISP sym_plists = NIL;
static LISP bashnum = NIL;
static LISP sym_e = NIL;
static LISP sym_f = NIL;

void init_storage_a1(long type)
{long j;
 struct user_type_hooks *p;
 set_gc_hooks(type,
	      array_gc_relocate,
	      array_gc_mark,
	      array_gc_scan,
	      array_gc_free,
	      &j);
 set_print_hooks(type,array_prin1);
 p = get_user_type_hooks(type);
 p->fast_print = array_fast_print;
 p->fast_read = array_fast_read;
 p->equal = array_equal;
 p->c_sxhash = array_sxhash;}

void init_storage_a(void)
{gc_protect(&bashnum);
 bashnum = newcell(tc_flonum);
 init_storage_a1(tc_string);
 init_storage_a1(tc_double_array);
 init_storage_a1(tc_long_array);
 init_storage_a1(tc_lisp_array);
 init_storage_a1(tc_byte_array);}

LISP array_gc_relocate(LISP ptr)
{LISP nw;
 if ((nw = heap) >= heap_end) gc_fatal_error();
 heap = nw+1;
 memcpy(nw,ptr,sizeof(struct obj));
 return(nw);}

void array_gc_scan(LISP ptr)
{long j;
 if TYPEP(ptr,tc_lisp_array)
   for(j=0;j < ptr->storage_as.lisp_array.dim; ++j)
     ptr->storage_as.lisp_array.data[j] =     
       gc_relocate(ptr->storage_as.lisp_array.data[j]);}

LISP array_gc_mark(LISP ptr)
{long j;
 if TYPEP(ptr,tc_lisp_array)
   for(j=0;j < ptr->storage_as.lisp_array.dim; ++j)
     gc_mark(ptr->storage_as.lisp_array.data[j]);
 return(NIL);}

void array_gc_free(LISP ptr)
{switch (ptr->type)
   {case tc_string:
    case tc_byte_array:
      free(ptr->storage_as.string.data);
      break;
    case tc_double_array:
      free(ptr->storage_as.double_array.data);
      break;
    case tc_long_array:
      free(ptr->storage_as.long_array.data);
      break;
    case tc_lisp_array:
      free(ptr->storage_as.lisp_array.data);
      break;}}

void array_prin1(LISP ptr,struct gen_printio *f)
{int j;
 switch (ptr->type)
   {case tc_string:
      gput_st(f,"\"");
      if (strcspn(ptr->storage_as.string.data,"\"\\\n\r\t") ==
	  strlen(ptr->storage_as.string.data))
	gput_st(f,ptr->storage_as.string.data);
      else
	{int n,c;
	 char cbuff[3];
	 n = strlen(ptr->storage_as.string.data);
	 for(j=0;j<n;++j)
	   switch(c = ptr->storage_as.string.data[j])
	     {case '\\':
	      case '"':
		cbuff[0] = '\\';
		cbuff[1] = c;
		cbuff[2] = 0;
		gput_st(f,cbuff);
		break;
	      case '\n':
		gput_st(f,"\\n");
		break;
	      case '\r':
		gput_st(f,"\\r");
		break;
	      case '\t':
		gput_st(f,"\\t");
		break;
	      default:
		cbuff[0] = c;
		cbuff[1] = 0;
		gput_st(f,cbuff);
		break;}}
      gput_st(f,"\"");