view release on metacpan or  search on metacpan

slib.c  view on Meta::CPAN

   if (strcmp(name,PNAME(CAR(l))) == 0)
     {no_interrupt(flag);
      return(CAR(l));}
 if (copyp == 1)
   {cname = (char *) must_malloc(strlen(name)+1);
    strcpy(cname,name);}
 else
   cname = name;
 sym = symcons(cname,unbound_marker);
 if (obarray_dim > 1) obarray[hash] = cons(sym,sl);
 oblistvar = cons(sym,oblistvar);
 no_interrupt(flag);
 return(sym);}

LISP cintern(char *name)
{return(gen_intern(name,0));}

LISP rintern(char *name)
{return(gen_intern(name,1));}

LISP intern(LISP name)
{return(rintern(get_c_string(name)));}

LISP subrcons(long type, char *name, SUBR_FUNC f)
{LISP z;
 NEWCELL(z,type);
 (*z).storage_as.subr.name = name;
 (*z).storage_as.subr0.f = f;
 return(z);}

LISP closure(LISP env,LISP code)
{LISP z;
 NEWCELL(z,tc_closure);
 (*z).storage_as.closure.env = env;
 (*z).storage_as.closure.code = code;
 return(z);}

void gc_protect(LISP *location)
{gc_protect_n(location,1);}

void gc_protect_n(LISP *location,long n)
{struct gc_protected *reg;
 reg = (struct gc_protected *) must_malloc(sizeof(struct gc_protected));
 (*reg).location = location;
 (*reg).length = n;
 (*reg).next = protected_registers;
  protected_registers = reg;}

void gc_protect_sym(LISP *location,char *st)
{*location = cintern(st);
 gc_protect(location);}

void scan_registers(void)
{struct gc_protected *reg;
 LISP *location;
 long j,n;
 for(reg = protected_registers; reg; reg = (*reg).next)
   {location = (*reg).location;
    n = (*reg).length;
    for(j=0;j<n;++j)
      location[j] = gc_relocate(location[j]);}}

void __stdcall init_storage(void)
{long j;
 LISP stack_start;
 if (stack_start_ptr == NULL)
   stack_start_ptr = &stack_start;
 init_storage_1();
 init_storage_a();
 set_gc_hooks(tc_c_file,0,0,0,file_gc_free,&j);
 set_print_hooks(tc_c_file,file_prin1);}

void init_storage_1(void)
{LISP ptr;
 long j;
 tkbuffer = (char *) must_malloc(TKBUFFERN+1);
 if (((gc_kind_copying == 1) && (nheaps != 2)) || (nheaps < 1))
   err("invalid number of heaps",NIL);
 heaps = (LISP *) must_malloc(sizeof(LISP) * nheaps);
 for(j=0;j<nheaps;++j) heaps[j] = NULL;
 heaps[0] = (LISP) must_malloc(sizeof(struct obj)*heap_size);
 heap = heaps[0];
 heap_org = heap;
 heap_end = heap + heap_size;
 if (gc_kind_copying == 1)
   heaps[1] = (LISP) must_malloc(sizeof(struct obj)*heap_size);
 else
   freelist = NIL;
 gc_protect(&oblistvar);
 if (obarray_dim > 1)
   {obarray = (LISP *) must_malloc(sizeof(LISP) * obarray_dim);
    for(j=0;j<obarray_dim;++j)
      obarray[j] = NIL;
    gc_protect_n(obarray,obarray_dim);}
 unbound_marker = cons(cintern("**unbound-marker**"),NIL);
 gc_protect(&unbound_marker);
 eof_val = cons(cintern("eof"),NIL);
 gc_protect(&eof_val);
 gc_protect_sym(&sym_t,"t");
 setvar(sym_t,sym_t,NIL);
 setvar(cintern("nil"),NIL,NIL);
 setvar(cintern("let"),cintern("let-internal-macro"),NIL);
 setvar(cintern("let*"),cintern("let*-macro"),NIL);
 setvar(cintern("letrec"),cintern("letrec-macro"),NIL);
 gc_protect_sym(&sym_errobj,"errobj");
 setvar(sym_errobj,NIL,NIL);
 gc_protect_sym(&sym_catchall,"all");
 gc_protect_sym(&sym_progn,"begin");
 gc_protect_sym(&sym_lambda,"lambda");
 gc_protect_sym(&sym_quote,"quote");
 gc_protect_sym(&sym_dot,".");
 gc_protect_sym(&sym_after_gc,"*after-gc*");
 setvar(sym_after_gc,NIL,NIL);
 gc_protect_sym(&sym_eval_history_ptr,"*eval-history-ptr*");
 setvar(sym_eval_history_ptr,NIL,NIL);
 if (inums_dim > 0)
   {inums = (LISP *) must_malloc(sizeof(LISP) * inums_dim);
    for(j=0;j<inums_dim;++j)
      {NEWCELL(ptr,tc_flonum);
       FLONM(ptr) = j;
       inums[j] = ptr;}

slib.c  view on Meta::CPAN

{init_subr(name,tc_subr_2,(SUBR_FUNC)fcn);}

void init_subr_2n(char *name, LISP (*fcn)(LISP,LISP))
{init_subr(name,tc_subr_2n,(SUBR_FUNC)fcn);}

void init_subr_3(char *name, LISP (*fcn)(LISP,LISP,LISP))
{init_subr(name,tc_subr_3,(SUBR_FUNC)fcn);}

void init_subr_4(char *name, LISP (*fcn)(LISP,LISP,LISP,LISP))
{init_subr(name,tc_subr_4,(SUBR_FUNC)fcn);}

void init_subr_5(char *name, LISP (*fcn)(LISP,LISP,LISP,LISP,LISP))
{init_subr(name,tc_subr_5,(SUBR_FUNC)fcn);}

void init_lsubr(char *name, LISP (*fcn)(LISP))
{init_subr(name,tc_lsubr,(SUBR_FUNC)fcn);}

void init_fsubr(char *name, LISP (*fcn)(LISP,LISP))
{init_subr(name,tc_fsubr,(SUBR_FUNC)fcn);}

void init_msubr(char *name, LISP (*fcn)(LISP *,LISP *))
{init_subr(name,tc_msubr,(SUBR_FUNC)fcn);}

LISP assq(LISP x,LISP alist)
{LISP l,tmp;
 for(l=alist;CONSP(l);l=CDR(l))
   {tmp = CAR(l);
    if (CONSP(tmp) && EQ(CAR(tmp),x)) return(tmp);
    INTERRUPT_CHECK();}
 if EQ(l,NIL) return(NIL);
 return(err("improper list to assq",alist));}


struct user_type_hooks *get_user_type_hooks(long type)
{long n;
 if (user_types == NULL)
   {n = sizeof(struct user_type_hooks) * tc_table_dim;
    user_types = (struct user_type_hooks *) must_malloc(n);
    memset(user_types,0,n);}
 if ((type >= 0) && (type < tc_table_dim))
   return(&user_types[type]);
 else
   err("type number out of range",NIL);
 return(NULL);}

long allocate_user_tc(void)
{long x = user_tc_next;
 if (x > tc_user_max)
   err("ran out of user type codes",NIL);
 ++user_tc_next;
 return(x);}
 
void set_gc_hooks(long type,
		  LISP (*rel)(LISP),
		  LISP (*mark)(LISP),
		  void (*scan)(LISP),
		  void (*free)(LISP),
		  long *kind)
{struct user_type_hooks *p;
 p = get_user_type_hooks(type);
 p->gc_relocate = rel;
 p->gc_scan = scan;
 p->gc_mark = mark;
 p->gc_free = free;
 *kind = gc_kind_copying;}

LISP gc_relocate(LISP x)
{LISP nw;
 struct user_type_hooks *p;
 if EQ(x,NIL) return(NIL);
 if ((*x).gc_mark == 1) return(CAR(x));
 switch TYPE(x)
   {case tc_flonum:
    case tc_cons:
    case tc_symbol:
    case tc_closure:
    case tc_subr_0:
    case tc_subr_1:
    case tc_subr_2:
    case tc_subr_2n:
    case tc_subr_3:
    case tc_subr_4:
    case tc_subr_5:
    case tc_lsubr:
    case tc_fsubr:
    case tc_msubr:
      if ((nw = heap) >= heap_end) gc_fatal_error();
      heap = nw+1;
      memcpy(nw,x,sizeof(struct obj));
      break;
    default:
      p = get_user_type_hooks(TYPE(x));
      if (p->gc_relocate)
	nw = (*p->gc_relocate)(x);
      else
	{if ((nw = heap) >= heap_end) gc_fatal_error();
	 heap = nw+1;
	 memcpy(nw,x,sizeof(struct obj));}}
 (*x).gc_mark = 1;
 CAR(x) = nw;
 return(nw);}

LISP get_newspace(void)
{LISP newspace;
 if (heap_org == heaps[0])
   newspace = heaps[1];
 else
   newspace = heaps[0];
 heap = newspace;
 heap_org = heap;
 heap_end = heap + heap_size;
 return(newspace);}

void scan_newspace(LISP newspace)
{LISP ptr;
 struct user_type_hooks *p;
 for(ptr=newspace; ptr < heap; ++ptr)
   {switch TYPE(ptr)
      {case tc_cons:
       case tc_closure:
	 CAR(ptr) = gc_relocate(CAR(ptr));
	 CDR(ptr) = gc_relocate(CDR(ptr));
	 break;
       case tc_symbol:
	 VCELL(ptr) = gc_relocate(VCELL(ptr));
	 break;
       case tc_flonum:
       case tc_subr_0:
       case tc_subr_1:
       case tc_subr_2:
       case tc_subr_2n:
       case tc_subr_3:
       case tc_subr_4:
       case tc_subr_5:
       case tc_lsubr:
       case tc_fsubr:
       case tc_msubr:
	 break;
       default:
	 p = get_user_type_hooks(TYPE(ptr));
	 if (p->gc_scan) (*p->gc_scan)(ptr);}}}

void free_oldspace(LISP space,LISP end)
{LISP ptr;
 struct user_type_hooks *p;
 for(ptr=space; ptr < end; ++ptr)
   if (ptr->gc_mark == 0)
     switch TYPE(ptr)
       {case tc_cons:
	case tc_closure:
	case tc_symbol:
	case tc_flonum:
	case tc_subr_0:
	case tc_subr_1:
	case tc_subr_2:
	case tc_subr_2n:
	case tc_subr_3:
	case tc_subr_4:
	case tc_subr_5:
	case tc_lsubr:
	case tc_fsubr:
	case tc_msubr:
	  break;
	default:
	  p = get_user_type_hooks(TYPE(ptr));
	  if (p->gc_free) (*p->gc_free)(ptr);}}
      
void gc_stop_and_copy(void)
{LISP newspace,oldspace,end;
 long flag;
 flag = no_interrupt(1);
 errjmp_ok = 0;
 oldspace = heap_org;
 end = heap;
 old_heap_used = end - oldspace;
 newspace = get_newspace();
 scan_registers();
 scan_newspace(newspace);
 free_oldspace(oldspace,end);
 errjmp_ok = 1;
 no_interrupt(flag);}

LISP allocate_aheap(void)
{long j,flag;
 LISP ptr,end,next;