SCM SCM_prin (SCM x) {
if ( SCM_FixnumP(x) ) {
fprintf(stdout,"%ld",SCM_Fixnum2int(x));
} else {
switch SCM_2tag(x) {
case SCM_NULL_TAG: {
fprintf(stdout,"()");
break;
}
case SCM_PAIR_TAG: {
fprintf(stdout,"(");
SCM_prin(SCM_Car(x));
SCM_prin_list(SCM_cdr(x));
fprintf(stdout,")");
break;
}
case SCM_BOOLEAN_TAG: {
fprintf(stdout,"#%c",(SCM_EqP(x,SCM_true)?'T':'F'));
break;
}
case SCM_UNDEFINED_TAG: {
fprintf(stdout,"#<UFO>");
break;
}
case SCM_SYMBOL_TAG: {
SCM str = SCM_Unwrap(x)->symbol.pname;
char *Cstring = SCM_Unwrap(str)->string.Cstring;
fprintf(stdout,"%s",Cstring);
break;
}
case SCM_STRING_TAG: {
char *Cstring = SCM_Unwrap(x)->string.Cstring;
fprintf(stdout,"\"%s\"",Cstring);
break;
}
case SCM_SUBR_TAG: {
fprintf(stdout,"#<Subr@%p>",(void *)(x));
break;
}
case SCM_CLOSURE_TAG: {
fprintf(stdout,"#<Closure@%p>",(void *)(x));
break;
}
case SCM_ESCAPE_TAG: {
fprintf(stdout,"#<Continuation@%p>",(void *)(x));
break;
}
default:
fprintf(stdout,"#<Something@%p>",(void *)(x));
break;
}
}
return (x);
}
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! */
}
}
}
}
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_invoke_continuation (SCM self, unsigned long number, va_list arguments) {
SCM current_k = va_arg(arguments,SCM);
SCM value = va_arg(arguments,SCM);
return SCM_invoke1(SCM_Unwrap(self)->closure.environment[0],value);
}
