/*
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

This file is part of GNU Common Lisp, herein referred to as GCL

GCL is free software; you can redistribute it and/or modify it under
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GCL 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 Library General Public 
License for more details.

You should have received a copy of the GNU Library General Public License 
along with GCL; see the file COPYING.  If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

*/

/*
	cfun.c
*/

#include "include.h"


#define dcheck_vs do{if (vs_base < vs_org || vs_top < vs_org) error("bad vs");} while (0)
#define dcheck_type(a,b) check_type(a,b) ; dcheck_vs 

#define PADDR(i) ((char *)(long)(sSPinit->s.s_dbind->v.v_self[fix(i)]))
object sSPinit,sSPmemory;

object
make_cfun(self, name, data, start, size)
int (*self)();
object name, data;
char *start;
int size;
{
	object cf;

	cf = alloc_object(t_cfun);
	cf->cf.cf_self = self;
	cf->cf.cf_name = name;
	cf->cf.cf_data = data;
	if(data && type_of(data)==t_cfdata)
	  { data->cfd.cfd_start=start; 
	    data->cfd.cfd_size=size;}
	  else if(size) FEerror("Bad call to make_cfun",0);
	return(cf);
}
object
make_sfun(name,self,argd, data)
int argd;
object (*self)();
object name, data;
{object sfn;
       
	sfn = alloc_object(t_sfun);
        if(argd >15) sfn->d.t = (int)t_gfun;
	sfn->sfn.sfn_self = self;
	sfn->sfn.sfn_name = name;
	sfn->sfn.sfn_data = data;
        sfn->sfn.sfn_argd = argd;
	return(sfn);
}

#define VFUN_MIN_ARGS(argd) (argd & 0xff)
#define VFUN_MAX_ARGS(argd) ((argd) >> 8)

object
make_vfun(name,self,argd, data)
int (*self)(),argd;
object name, data;
{object vfn;
       
	vfn = alloc_object(t_vfun);
	vfn->vfn.vfn_self = self;
	vfn->vfn.vfn_name = name;
	vfn->vfn.vfn_minargs = VFUN_MIN_ARGS(argd);
        vfn->vfn.vfn_maxargs = VFUN_MAX_ARGS(argd);
        vfn->vfn.vfn_data = data;
	return(vfn);
}

object
make_cclosure_new(self, name, env, data)
int (*self)();
object name, env, data;
{
	object cc;

	cc = alloc_object(t_cclosure);
	cc->cc.cc_self = self;
	cc->cc.cc_name = name;
	cc->cc.cc_env = env;
	cc->cc.cc_data = data;
	cc->cc.cc_turbo = NULL;
	return(cc);
}


object
make_cclosure(self, name, env, data, start, size)
int (*self)();
object name, env, data;
char *start;
int size;
{
	if(data && type_of(data)==t_cfdata)
	  { data->cfd.cfd_start=start; 
	    data->cfd.cfd_size=size;}
	  else if(size) FEerror("Bad call to make_cclosure",0);
	return make_cclosure_new(self,name,env,data);

}


DEFUNO("MC",object,fSmc,SI
   ,2,2,NONE,OO,OO,OO,OO,siLmc,"")(name,address) 
object name,address;
{ /* 2 args */
  dcheck_type(name,t_symbol);
  dcheck_type(address,t_fixnum);
  dcheck_type(sSPmemory->s.s_dbind,t_cfdata);
  name=make_cclosure_new(PADDR(address),name,Cnil,
			 sSPmemory->s.s_dbind);
  RETURN1(name);
}

object
MFsfun(sym,self,argd,data)
     object sym,data;
     int argd,(*self)();
{object sfn;
 if (type_of(sym)!=t_symbol) not_a_symbol(sym);
 if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
   sym->s.s_sfdef = NOT_SPECIAL;
 sfn = make_sfun(sym,self,argd,data);
 sym = clear_compiler_properties(sym,sfn);
 sym->s.s_gfdef = sfn;
 sym->s.s_mflag = FALSE;
}

DEFUNO("MFSFUN",object,fSmfsfun,SI
   ,3,3,NONE,OO,OO,OO,OO,siLmfsfun,"")(name,address,argd) 
object name,address,argd;
{ /* 3 args */
  dcheck_type(address,t_fixnum);
  MFsfun(name,PADDR(address),fix(argd),sSPmemory->s.s_dbind);RETURN1(name);
}


object
MFvfun(sym,self,argd,data)
     object sym,data;
     int argd,(*self)();
{object vfn;
 if (type_of(sym)!=t_symbol) not_a_symbol(sym);
 if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
   sym->s.s_sfdef = NOT_SPECIAL;
 dcheck_type(data,t_cfdata);
 vfn = make_vfun(sym,self,argd,data);
 sym = clear_compiler_properties(sym,vfn);
 sym->s.s_gfdef = vfn;
 sym->s.s_mflag = FALSE;
}

DEFUNO("MFVFUN",object,fSmfvfun,SI
   ,3,3,NONE,OO,OO,OO,OO,siLmfvfun,"")(name,address,argd)
object name,address,argd;
{ /* 3 args */
  MFvfun(name,PADDR(address),fix(argd),sSPmemory->s.s_dbind);
  RETURN1(name);
}



object
MFvfun_key(sym,self,argd,data,keys)
     object sym,data;
     int argd,(*self)();
     char *keys;
{if (data) set_key_struct(keys,data);
 return MFvfun(sym,self,argd,data);
}

DEFUNO("MFVFUN-KEY",object,fSmfvfun_key,SI
   ,4,4,NONE,OO,OO,OO,OO,siLmfvfun_key,"")(symbol,address,argd,keys) 
object symbol,address,argd,keys;
{ /* 4 args */
 MFvfun_key(symbol,PADDR(address),fix(argd),sSPmemory->s.s_dbind,PADDR(keys));
 RETURN1(symbol);
}


object MFnew(sym,self,data)
     object sym,data;
 int (*self)();
{
	object cf;

	if (type_of(sym) != t_symbol)
		not_a_symbol(sym);
	if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
		sym->s.s_sfdef = NOT_SPECIAL;
	cf = alloc_object(t_cfun);
	cf->cf.cf_self = self;
	cf->cf.cf_name = sym;
	cf->cf.cf_data = data;
	sym = clear_compiler_properties(sym,cf);
 	sym->s.s_gfdef = cf;
	sym->s.s_mflag = FALSE;
}

DEFUNO("MF",object,fSmf,SI
   ,2,2,NONE,OO,OO,OO,OO,siLmf,"")(name,addr)
object name,addr;
{ /* 2 args */
  MFnew(name,PADDR(addr),sSPmemory->s.s_dbind);
  RETURN1(name);
}


object
MF(sym, self, start, size, data)
object sym;
int (*self)();
char *start;
int size;
object data;
{ if(data && type_of(data)==t_cfdata)
	  { data->cfd.cfd_start=start; 
	    data->cfd.cfd_size=size;}
	  else if(size) FEerror("Bad call to make_cfun",0);
  return(MFnew(sym,self,data));
}

object
MM(sym, self, start, size, data)
object sym;
int (*self)();
char *start;
int size;
object data;
{
	object cf;

	if (type_of(sym) != t_symbol)
		not_a_symbol(sym);
	if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
		sym->s.s_sfdef = NOT_SPECIAL;
	cf = alloc_object(t_cfun);
	cf->cf.cf_self = self;
	cf->cf.cf_name = sym;
	cf->cf.cf_data = data;
	data->cfd.cfd_start=start; 
	data->cfd.cfd_size=size;
	sym = 	clear_compiler_properties(sym,cf);
	sym->s.s_gfdef = cf;
	sym->s.s_mflag = TRUE;
}

DEFUNO("MM",object,fSmm,SI
   ,2,2,NONE,OO,OO,OO,OO,siLmm,"")(name,addr)
object name,addr;
{ /* 2 args */
  MM(name,PADDR(addr),
    /* bit wasteful to pass these in just to be reset to themselves..*/
    sSPmemory->s.s_dbind->cfd.cfd_start,
    sSPmemory->s.s_dbind->cfd.cfd_size,
    sSPmemory->s.s_dbind
     );RETURN1(name);
}

  

object
make_function(s, f)
char *s;
int (*f)();
{
	object x;
	vs_mark;

	x = make_ordinary(s);
	vs_push(x);
	x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0);
	x->s.s_mflag = FALSE;
	vs_reset;
	return(x);
}

object
make_si_sfun(s, f,argd)
char *s;
int (*f)();
int argd;
{  object x= make_si_ordinary(s);
   x->s.s_gfdef = make_sfun( x,f,argd, Cnil);
   x->s.s_mflag = FALSE;
   return(x);
}

object
make_si_vfun1(s, f,argd)
char *s;
int (*f)();
int argd;
{  object x= make_si_ordinary(s);
   x->s.s_gfdef = make_vfun( x,f,argd, Cnil);
   x->s.s_mflag = FALSE;
   return(x);
}


object
make_si_function(s, f)
char *s;
int (*f)();
{
	object x;
	vs_mark;

	x = make_si_ordinary(s);
	vs_push(x);
	x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0);
	x->s.s_mflag = FALSE;
	vs_reset;
	return(x);
}




object
make_special_form(s, f)
char *s;
int (*f)();
{
	object x;
	x = make_ordinary(s);
	x->s.s_sfdef = f;
	return(x);
}

DEFUNO("COMPILED-FUNCTION-NAME",object,fScompiled_function_name,SI
   ,1,1,NONE,OO,OO,OO,OO,siLcompiled_function_name,"")(fun)
object fun;
{
	/* 1 args */
	switch(type_of(fun)) {
	case t_cfun:
	case t_afun:
	case t_closure:
	case t_sfun:
	case t_vfun:
	case t_cclosure:
	case t_gfun:
	  fun = fun->cf.cf_name;
	  break;
	default:
	  FEerror("~S is not a compiled-function.", 1, fun);
	}RETURN1(fun);
}

turbo_closure(fun)
object fun;
{
  object l,*block;
  object endp_temp;
  int n;

  if(fun->cc.cc_turbo==NULL)
    {BEGIN_NO_INTERRUPT;
     for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr);
    {
     block= AR_ALLOC(alloc_contblock,(1+n),object);
     *block=make_fixnum(n);
     fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */
     for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
       fun->cc.cc_turbo[n] = l;}
      END_NO_INTERRUPT;
   }
}

DEFUNO("TURBO-CLOSURE",object,fSturbo_closure,SI
   ,1,1,NONE,OO,OO,OO,OO,siLturbo_closure,"")(funobj)
object funobj;
{
	/* 1 args */
	if (type_of(funobj) == t_cclosure)
		turbo_closure(funobj);
	RETURN1(funobj);
}



init_cfun()
{
	
}

