1 |
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc. |
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc. |
2 |
* |
* |
3 |
* This program is free software; you can redistribute it and/or modify |
* This program is free software; you can redistribute it and/or modify |
4 |
* it under the terms of the GNU General Public License as published by |
* it under the terms of the GNU General Public License as published by |
80 |
#include "libguile/alist.h" |
#include "libguile/alist.h" |
81 |
#include "libguile/eq.h" |
#include "libguile/eq.h" |
82 |
#include "libguile/continuations.h" |
#include "libguile/continuations.h" |
83 |
|
#include "libguile/futures.h" |
84 |
#include "libguile/throw.h" |
#include "libguile/throw.h" |
85 |
#include "libguile/smob.h" |
#include "libguile/smob.h" |
86 |
#include "libguile/macros.h" |
#include "libguile/macros.h" |
3804 |
*/ |
*/ |
3805 |
|
|
3806 |
static SCM |
static SCM |
3807 |
|
call_subr0_0 (SCM proc) |
3808 |
|
{ |
3809 |
|
return SCM_SUBRF (proc) (); |
3810 |
|
} |
3811 |
|
|
3812 |
|
static SCM |
3813 |
|
call_subr1o_0 (SCM proc) |
3814 |
|
{ |
3815 |
|
return SCM_SUBRF (proc) (SCM_UNDEFINED); |
3816 |
|
} |
3817 |
|
|
3818 |
|
static SCM |
3819 |
|
call_lsubr_0 (SCM proc) |
3820 |
|
{ |
3821 |
|
return SCM_SUBRF (proc) (SCM_EOL); |
3822 |
|
} |
3823 |
|
|
3824 |
|
SCM |
3825 |
|
scm_i_call_closure_0 (SCM proc) |
3826 |
|
{ |
3827 |
|
return scm_eval_body (SCM_CLOSURE_BODY (proc), |
3828 |
|
SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
3829 |
|
SCM_EOL, |
3830 |
|
SCM_ENV (proc))); |
3831 |
|
} |
3832 |
|
|
3833 |
|
scm_t_trampoline_0 |
3834 |
|
scm_trampoline_0 (SCM proc) |
3835 |
|
{ |
3836 |
|
if (SCM_IMP (proc)) |
3837 |
|
return 0; |
3838 |
|
if (SCM_DEBUGGINGP) |
3839 |
|
return scm_call_0; |
3840 |
|
switch (SCM_TYP7 (proc)) |
3841 |
|
{ |
3842 |
|
case scm_tc7_subr_0: |
3843 |
|
return call_subr0_0; |
3844 |
|
case scm_tc7_subr_1o: |
3845 |
|
return call_subr1o_0; |
3846 |
|
case scm_tc7_lsubr: |
3847 |
|
return call_lsubr_0; |
3848 |
|
case scm_tcs_closures: |
3849 |
|
{ |
3850 |
|
SCM formals = SCM_CLOSURE_FORMALS (proc); |
3851 |
|
if (SCM_NULLP (formals) || SCM_SYMBOLP (formals)) |
3852 |
|
return scm_i_call_closure_0; |
3853 |
|
else |
3854 |
|
return 0; |
3855 |
|
} |
3856 |
|
case scm_tcs_struct: |
3857 |
|
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
3858 |
|
return scm_call_generic_0; |
3859 |
|
else if (!SCM_I_OPERATORP (proc)) |
3860 |
|
return 0; |
3861 |
|
return scm_call_0; |
3862 |
|
case scm_tc7_smob: |
3863 |
|
if (SCM_SMOB_APPLICABLE_P (proc)) |
3864 |
|
return SCM_SMOB_DESCRIPTOR (proc).apply_0; |
3865 |
|
else |
3866 |
|
return 0; |
3867 |
|
/* fall through */ |
3868 |
|
case scm_tc7_asubr: |
3869 |
|
case scm_tc7_rpsubr: |
3870 |
|
case scm_tc7_cclo: |
3871 |
|
case scm_tc7_pws: |
3872 |
|
return scm_call_0; |
3873 |
|
default: |
3874 |
|
return 0; /* not applicable on one arg */ |
3875 |
|
} |
3876 |
|
} |
3877 |
|
|
3878 |
|
static SCM |
3879 |
call_subr1_1 (SCM proc, SCM arg1) |
call_subr1_1 (SCM proc, SCM arg1) |
3880 |
{ |
{ |
3881 |
return SCM_SUBRF (proc) (arg1); |
return SCM_SUBRF (proc) (arg1); |
3961 |
case scm_tcs_closures: |
case scm_tcs_closures: |
3962 |
{ |
{ |
3963 |
SCM formals = SCM_CLOSURE_FORMALS (proc); |
SCM formals = SCM_CLOSURE_FORMALS (proc); |
3964 |
if (!SCM_CONSP (formals) || SCM_NULLP (SCM_CDR (formals))) |
if ((SCM_CONSP (formals) && SCM_NULLP (SCM_CDR (formals))) |
3965 |
|
|| SCM_SYMBOLP (formals)) |
3966 |
return call_closure_1; |
return call_closure_1; |
3967 |
else |
else |
3968 |
return 0; |
return 0; |