SCM SCM_apply (unsigned long number, va_list arguments) {
SCM args[31];
SCM last_arg;
SCM fun = va_arg(arguments,SCM);
unsigned long i;
for ( i=0 ; i<number-1 ; i++ ) {
args[i] = va_arg(arguments,SCM);
}
last_arg = args[--i];
while ( SCM_PairP(last_arg) ) {
args[i++] = SCM_Car(last_arg);
last_arg = SCM_Cdr(last_arg);
}
if ( ! SCM_NullP(last_arg) ) {
SCM_error(SCM_ERR_APPLY_ARG);
}
switch ( i ) {
case 0: return SCM_invoke(fun,0);
case 1: return SCM_invoke(fun,1,args[0]);
case 2: return SCM_invoke(fun,2,args[0],args[1]);
case 3: return SCM_invoke(fun,3,args[0],args[1],args[2]);
case 4: return SCM_invoke(fun,4,args[0],args[1],args[2],args[3]);
case 5: return SCM_invoke(fun,5,args[0],args[1],args[2],args[3],
args[4]);
case 6: return SCM_invoke(fun,6,args[0],args[1],args[2],args[3],
args[4],args[5]);
case 7: return SCM_invoke(fun,7,args[0],args[1],args[2],args[3],
args[4],args[5],args[6]);
case 8: return SCM_invoke(fun,8,args[0],args[1],args[2],args[3],
args[4],args[5],args[6],args[7]);
case 9: return SCM_invoke(fun,9,args[0],args[1],args[2],args[3],
args[4],args[5],args[6],args[7],args[8]);
case 10: return SCM_invoke(fun,10,args[0],args[1],args[2],args[3],
args[4],args[5],args[6],args[7],args[8],args[9]);
case 11: return SCM_invoke(fun,11,args[0],args[1],args[2],args[3],
args[4],args[5],args[6],args[7],args[8],args[9],
args[10]);
case 12: return SCM_invoke(fun,12,args[0],args[1],args[2],args[3],
args[4],args[5],args[6],args[7],args[8],args[9],
args[10],args[11]);
case 13: return SCM_invoke(fun,13,args[0],args[1],args[2],args[3],
args[4],args[5],args[6],args[7],args[8],args[9],
args[10],args[11],args[12]);
case 14: return SCM_invoke(fun,14,args[0],args[1],args[2],args[3],
args[4],args[5],args[6],args[7],args[8],args[9],
args[10],args[11],args[12],args[13]);
/* If this were less cumbersome, I will add cases up to 31. */
default: return SCM_error(SCM_ERR_APPLY_SIZE);
}
}
SCM SCM_allocate_continuation (struct SCM_jmp_buf *address) {
SCMref continuation = (SCMref) malloc(sizeof(struct SCM_unwrapped_escape));
if (continuation == (SCMref) NULL) SCM_error(SCM_ERR_CANT_ALLOC);
continuation->escape.header.tag = SCM_ESCAPE_TAG;
continuation->escape.stack_address = address;
return SCM_Wrap(continuation);
}
SCM SCM_cons (SCM x, SCM y) {
SCMref cell = (SCMref) malloc(sizeof(struct SCM_unwrapped_pair));
if (cell == (SCMref) NULL) SCM_error(SCM_ERR_CANT_ALLOC);
cell->pair.header.tag = SCM_PAIR_TAG;
cell->pair.car = x;
cell->pair.cdr = y;
return SCM_Wrap(cell);
}
SCM SCM_close (SCM (*Cfunction)(void), long arity, unsigned long size, ...) {
SCMref result = (SCMref) malloc(sizeof(struct SCM_unwrapped_closure)
+ (size-1)*sizeof(SCM) );
unsigned long i;
va_list args;
if (result == (SCMref) NULL) SCM_error(SCM_ERR_CANT_ALLOC);
result->closure.header.tag = SCM_CLOSURE_TAG;
result->closure.behavior = Cfunction;
result->closure.arity = arity;
va_start(args,size);
for ( i=0 ; i<size ; i++ ) {
result->closure.environment[i] = va_arg(args,SCM);
}
va_end(args);
return SCM_Wrap(result);
}
object *
copy_object (object *obj)
{
object *ret = NULL;
if (NULL == obj)
return NULL;
else if (SCM_VOID == obj->type)
ret = SCM_void ();
else if (SCM_ERROR == obj->type)
ret = SCM_error (((error_object *) obj)->error,
((error_object *) obj)->msg);
else if (SCM_ATOM == obj->type)
ret = SCM_atom (((atom_object *) obj)->name);
else if (SCM_BOOL == obj->type)
ret = SCM_bool (((bool_object *) obj)->value);
else if (SCM_VARIABLE == obj->type)
ret = SCM_variable (((variable_object *) obj)->name,
copy_object (((variable_object *) obj)->value));
else if (SCM_NUMBER == obj->type)
ret = SCM_number_from_double (((number_object *) obj)->num);
else if (SCM_STRING == obj->type)
ret = SCM_string (((string_object *) obj)->str);
else if (SCM_PAIR == obj->type)
ret = SCM_cons (copy_object (car (obj)), copy_object (cdr (obj)));
else if (SCM_FUNC == obj->type)
ret = SCM_func (((func_object *) obj)->fn);
else if (SCM_LAMBDA == obj->type)
ret = SCM_lambda (copy_object (((lambda_object *) obj)->args),
copy_object (((lambda_object *) obj)->sexp));
else
{
print_fatal (ETYPE);
exit (1);
}
return ret;
}
SCM SCM_allocate_box (SCM v) {
SCM cell = (SCM) malloc(sizeof(struct SCM_box));
if (cell == (SCM) NULL) SCM_error(SCM_ERR_CANT_ALLOC);
cell->box.content = v;
return (cell);
}
SCM SCM_set_cdr (SCM x, SCM y) {
if ( SCM_PairP(x) ) {
SCM_Unwrap(x)->pair.cdr = y;
return x;
} else return SCM_error(SCM_ERR_SET_CDR);
}
SCM SCM_cdr (SCM x) {
if ( SCM_PairP(x) ) {
return SCM_Cdr(x);
} else return SCM_error(SCM_ERR_CDR);
}
SCM SCM_car (SCM x) {
if ( SCM_PairP(x) ) {
return SCM_Car(x);
} else return SCM_error(SCM_ERR_CAR);
}
SCM SCM_invoke(SCM function, unsigned long number, ...) {
if ( SCM_FixnumP(function) ) {
return SCM_error(SCM_ERR_CANNOT_APPLY); /* Cannot apply a number! */
} else {
switch SCM_2tag(function) {
case SCM_SUBR_TAG: {
SCM (*behavior)(void) = (SCM_Unwrap(function)->subr).behavior;
long arity = (SCM_Unwrap(function)->subr).arity;
SCM result;
if ( arity >= 0 ) { /* Fixed arity subr */
if ( arity != number ) {
return SCM_error(SCM_ERR_WRONG_ARITY); /* Wrong arity! */
} else {
if ( arity == 0) {
result = behavior();
} else {
va_list args;
va_start(args,number);
{ SCM a0 ;
a0 = va_arg(args,SCM);
if ( arity == 1 ) {
result = ((SCM (*)(SCM)) *behavior)(a0);
} else {
SCM a1 ;
a1 = va_arg(args,SCM);
if ( arity == 2 ) {
result = ((SCM (*)(SCM,SCM)) *behavior)(a0,a1);
} else {
SCM a2 ;
a2 = va_arg(args,SCM);
if ( arity == 3 ) {
result = ((SCM (*)(SCM,SCM,SCM)) *behavior)(a0,a1,a2);
} else {
/* No fixed arity subr with more than 3 variables */
return SCM_error(SCM_ERR_INTERNAL);
}
}
}
}
va_end(args);
}
return result;
}
} else { /* Nary subr */
long min_arity = SCM_MinimalArity(arity) ;
if ( number < min_arity ) {
return SCM_error(SCM_ERR_MISSING_ARGS); /* Too less arguments! */
} else {
va_list args;
SCM result;
va_start(args,number);
result = ((SCM (*)(unsigned long,va_list)) *behavior)(number,args);
va_end(args);
return result;
}
}
}
case SCM_CLOSURE_TAG: {
SCM (*behavior)(void) = (SCM_Unwrap(function)->closure).behavior ;
long arity = (SCM_Unwrap(function)->closure).arity ;
SCM result;
va_list args;
va_start(args,number);
if ( arity >= 0 ) {
if ( arity != number ) { /* Wrong arity! */
return SCM_error(SCM_ERR_WRONG_ARITY);
} else {
result = ((SCM (*)(SCM,unsigned long,va_list)) *behavior)(function,number,args);
}
} else {
long min_arity = SCM_MinimalArity(arity) ;
if ( number < min_arity ) {
return SCM_error(SCM_ERR_MISSING_ARGS); /* Too less arguments! */
} else {
result = ((SCM (*)(SCM,unsigned long,va_list)) *behavior)(function,number,args);
}
}
va_end(args);
return result;
}
case SCM_ESCAPE_TAG: {
if ( number == 1) {
va_list args;
va_start(args,number);
jumpvalue = va_arg(args,SCM);
va_end(args);
{ struct SCM_jmp_buf *address =
SCM_Unwrap(function)->escape.stack_address;
if ( SCM_EqP(address->back_pointer,function)
&& ( (void *) &address SCM_STACK_HIGHER (void *) address ) ) {
longjmp(address->jb,1);
} else { /* surely out of dynamic extent! */
return SCM_error(SCM_ERR_OUT_OF_EXTENT);
}
}
} else {
return SCM_error(SCM_ERR_MISSING_ARGS); /* Too less arguments! */
}
}
default: {
return SCM_error(SCM_ERR_CANNOT_APPLY); /* Cannot apply! */
}
}
}
}
