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_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_car (SCM x) { if ( SCM_PairP(x) ) { return SCM_Car(x); } else return SCM_error(SCM_ERR_CAR); }