/[guile]/guile/guile-core/libguile/eval.c
ViewVC logotype

Diff of /guile/guile-core/libguile/eval.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.296 by dirk, Mon Apr 21 19:20:13 2003 UTC revision 1.297 by dirk, Wed Apr 23 18:27:37 2003 UTC
# Line 1  Line 1 
1  /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc.  /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
2   *   *
3   * This library is free software; you can redistribute it and/or   * This library is free software; you can redistribute it and/or
4   * modify it under the terms of the GNU Lesser General Public   * modify it under the terms of the GNU Lesser General Public
# Line 757  iqq (SCM form, SCM env, unsigned long in Line 757  iqq (SCM form, SCM env, unsigned long in
757    else if (SCM_VECTORP (form))    else if (SCM_VECTORP (form))
758      {      {
759        size_t i = SCM_VECTOR_LENGTH (form);        size_t i = SCM_VECTOR_LENGTH (form);
760        SCM const *data = SCM_VELTS (form);        SCM const *const data = SCM_VELTS (form);
761        SCM tmp = SCM_EOL;        SCM tmp = SCM_EOL;
762        while (i != 0)        while (i != 0)
763          tmp = scm_cons (data[--i], tmp);          tmp = scm_cons (data[--i], tmp);
# Line 1583  scm_eval_args (SCM l, SCM env, SCM proc) Line 1583  scm_eval_args (SCM l, SCM env, SCM proc)
1583    return results;    return results;
1584  }  }
1585    
1586    
1587  SCM  SCM
1588  scm_eval_body (SCM code, SCM env)  scm_eval_body (SCM code, SCM env)
1589  {  {
# Line 1611  scm_eval_body (SCM code, SCM env) Line 1612  scm_eval_body (SCM code, SCM env)
1612    return SCM_XEVALCAR (code, env);    return SCM_XEVALCAR (code, env);
1613  }  }
1614    
   
1615  #endif /* !DEVAL */  #endif /* !DEVAL */
1616    
1617    
# Line 1755  SCM_DEFINE (scm_eval_options_interface, Line 1755  SCM_DEFINE (scm_eval_options_interface,
1755  }  }
1756  #undef FUNC_NAME  #undef FUNC_NAME
1757    
1758    
1759  SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,  SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
1760              (SCM setting),              (SCM setting),
1761              "Option interface for the evaluator trap options.")              "Option interface for the evaluator trap options.")
# Line 1772  SCM_DEFINE (scm_evaluator_traps, "evalua Line 1773  SCM_DEFINE (scm_evaluator_traps, "evalua
1773  }  }
1774  #undef FUNC_NAME  #undef FUNC_NAME
1775    
1776    
1777  static SCM  static SCM
1778  deval_args (SCM l, SCM env, SCM proc, SCM *lloc)  deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
1779  {  {
# Line 1801  deval_args (SCM l, SCM env, SCM proc, SC Line 1803  deval_args (SCM l, SCM env, SCM proc, SC
1803  #define UPDATE_TOPLEVEL_ENV(env) \  #define UPDATE_TOPLEVEL_ENV(env) \
1804    do { \    do { \
1805      SCM p = scm_current_module_lookup_closure (); \      SCM p = scm_current_module_lookup_closure (); \
1806      if (p != SCM_CAR(env)) \      if (p != SCM_CAR (env)) \
1807        env = scm_top_level_env (p); \        env = scm_top_level_env (p); \
1808    } while (0)    } while (0)
1809    
# Line 3323  ret: Line 3325  ret:
3325  #ifndef DEVAL  #ifndef DEVAL
3326    
3327    
3328    
3329  /* Simple procedure calls  /* Simple procedure calls
3330   */   */
3331    
# Line 3446  scm_apply (SCM proc, SCM arg1, SCM args) Line 3449  scm_apply (SCM proc, SCM arg1, SCM args)
3449  #if 0  #if 0
3450  SCM  SCM
3451  scm_dapply (SCM proc, SCM arg1, SCM args)  scm_dapply (SCM proc, SCM arg1, SCM args)
3452  { /* empty */ }  {}
3453  #endif  #endif
3454    
3455    
# Line 3821  call_lsubr_0 (SCM proc) Line 3824  call_lsubr_0 (SCM proc)
3824  SCM  SCM
3825  scm_i_call_closure_0 (SCM proc)  scm_i_call_closure_0 (SCM proc)
3826  {  {
3827    return scm_eval_body (SCM_CLOSURE_BODY (proc),    const SCM env = SCM_ENV (proc);
3828                          SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),    const SCM formals = SCM_CLOSURE_FORMALS (proc);
3829                                          SCM_EOL,    const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env);
3830                                          SCM_ENV (proc)));    const SCM body = SCM_CLOSURE_BODY (proc);
3831      const SCM result = scm_eval_body (body, new_env);
3832      return result;
3833  }  }
3834    
3835  scm_t_trampoline_0  scm_t_trampoline_0
3836  scm_trampoline_0 (SCM proc)  scm_trampoline_0 (SCM proc)
3837  {  {
3838    if (SCM_IMP (proc))    if (SCM_IMP (proc))
3839      return 0;      return NULL;
3840    if (SCM_DEBUGGINGP)    if (SCM_DEBUGGINGP)
3841      return scm_call_0;      return scm_call_0;
3842    switch (SCM_TYP7 (proc))    switch (SCM_TYP7 (proc))
# Line 3848  scm_trampoline_0 (SCM proc) Line 3853  scm_trampoline_0 (SCM proc)
3853          if (SCM_NULLP (formals) || !SCM_CONSP (formals))          if (SCM_NULLP (formals) || !SCM_CONSP (formals))
3854            return scm_i_call_closure_0;            return scm_i_call_closure_0;
3855          else          else
3856            return 0;            return NULL;
3857        }        }
3858      case scm_tcs_struct:      case scm_tcs_struct:
3859        if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)        if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
3860          return scm_call_generic_0;          return scm_call_generic_0;
3861        else if (!SCM_I_OPERATORP (proc))        else if (!SCM_I_OPERATORP (proc))
3862          return 0;          return NULL;
3863        return scm_call_0;        return scm_call_0;
3864      case scm_tc7_smob:      case scm_tc7_smob:
3865        if (SCM_SMOB_APPLICABLE_P (proc))        if (SCM_SMOB_APPLICABLE_P (proc))
3866          return SCM_SMOB_DESCRIPTOR (proc).apply_0;          return SCM_SMOB_DESCRIPTOR (proc).apply_0;
3867        else        else
3868          return 0;          return NULL;
       /* fall through */  
3869      case scm_tc7_asubr:      case scm_tc7_asubr:
3870      case scm_tc7_rpsubr:      case scm_tc7_rpsubr:
3871      case scm_tc7_cclo:      case scm_tc7_cclo:
3872      case scm_tc7_pws:      case scm_tc7_pws:
3873        return scm_call_0;        return scm_call_0;
3874      default:      default:
3875        return 0; /* not applicable on one arg */        return NULL; /* not applicable on one arg */
3876      }      }
3877  }  }
3878    
# Line 3926  call_cxr_1 (SCM proc, SCM arg1) Line 3930  call_cxr_1 (SCM proc, SCM arg1)
3930  static SCM  static SCM
3931  call_closure_1 (SCM proc, SCM arg1)  call_closure_1 (SCM proc, SCM arg1)
3932  {  {
3933    return scm_eval_body (SCM_CLOSURE_BODY (proc),    const SCM env = SCM_ENV (proc);
3934                          SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),    const SCM formals = SCM_CLOSURE_FORMALS (proc);
3935                                          scm_list_1 (arg1),    const SCM args = scm_list_1 (arg1);
3936                                          SCM_ENV (proc)));    const SCM new_env = SCM_EXTEND_ENV (formals, args, env);
3937      const SCM body = SCM_CLOSURE_BODY (proc);
3938      const SCM result = scm_eval_body (body, new_env);
3939      return result;
3940  }  }
3941    
3942  scm_t_trampoline_1  scm_t_trampoline_1
3943  scm_trampoline_1 (SCM proc)  scm_trampoline_1 (SCM proc)
3944  {  {
3945    if (SCM_IMP (proc))    if (SCM_IMP (proc))
3946      return 0;      return NULL;
3947    if (SCM_DEBUGGINGP)    if (SCM_DEBUGGINGP)
3948      return scm_call_1;      return scm_call_1;
3949    switch (SCM_TYP7 (proc))    switch (SCM_TYP7 (proc))
# Line 3960  scm_trampoline_1 (SCM proc) Line 3967  scm_trampoline_1 (SCM proc)
3967              && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals))))              && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals))))
3968            return call_closure_1;            return call_closure_1;
3969          else          else
3970            return 0;            return NULL;
3971        }        }
3972      case scm_tcs_struct:      case scm_tcs_struct:
3973        if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)        if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
3974          return scm_call_generic_1;          return scm_call_generic_1;
3975        else if (!SCM_I_OPERATORP (proc))        else if (!SCM_I_OPERATORP (proc))
3976          return 0;          return NULL;
3977        return scm_call_1;        return scm_call_1;
3978      case scm_tc7_smob:      case scm_tc7_smob:
3979        if (SCM_SMOB_APPLICABLE_P (proc))        if (SCM_SMOB_APPLICABLE_P (proc))
3980          return SCM_SMOB_DESCRIPTOR (proc).apply_1;          return SCM_SMOB_DESCRIPTOR (proc).apply_1;
3981        else        else
3982          return 0;          return NULL;
       /* fall through */  
3983      case scm_tc7_asubr:      case scm_tc7_asubr:
3984      case scm_tc7_rpsubr:      case scm_tc7_rpsubr:
3985      case scm_tc7_cclo:      case scm_tc7_cclo:
3986      case scm_tc7_pws:      case scm_tc7_pws:
3987        return scm_call_1;        return scm_call_1;
3988      default:      default:
3989        return 0; /* not applicable on one arg */        return NULL; /* not applicable on one arg */
3990      }      }
3991  }  }
3992    
# Line 4005  call_lsubr_2 (SCM proc, SCM arg1, SCM ar Line 4011  call_lsubr_2 (SCM proc, SCM arg1, SCM ar
4011  static SCM  static SCM
4012  call_closure_2 (SCM proc, SCM arg1, SCM arg2)  call_closure_2 (SCM proc, SCM arg1, SCM arg2)
4013  {  {
4014    return scm_eval_body (SCM_CLOSURE_BODY (proc),    const SCM env = SCM_ENV (proc);
4015                          SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),    const SCM formals = SCM_CLOSURE_FORMALS (proc);
4016                                          scm_list_2 (arg1, arg2),    const SCM args = scm_list_2 (arg1, arg2);
4017                                          SCM_ENV (proc)));    const SCM new_env = SCM_EXTEND_ENV (formals, args, env);
4018      const SCM body = SCM_CLOSURE_BODY (proc);
4019      const SCM result = scm_eval_body (body, new_env);
4020      return result;
4021  }  }
4022    
4023  scm_t_trampoline_2  scm_t_trampoline_2
4024  scm_trampoline_2 (SCM proc)  scm_trampoline_2 (SCM proc)
4025  {  {
4026    if (SCM_IMP (proc))    if (SCM_IMP (proc))
4027      return 0;      return NULL;
4028    if (SCM_DEBUGGINGP)    if (SCM_DEBUGGINGP)
4029      return scm_call_2;      return scm_call_2;
4030    switch (SCM_TYP7 (proc))    switch (SCM_TYP7 (proc))
# Line 4039  scm_trampoline_2 (SCM proc) Line 4048  scm_trampoline_2 (SCM proc)
4048                          || !SCM_CONSP (SCM_CDDR (formals))))))                          || !SCM_CONSP (SCM_CDDR (formals))))))
4049            return call_closure_2;            return call_closure_2;
4050          else          else
4051            return 0;            return NULL;
4052        }        }
4053      case scm_tcs_struct:      case scm_tcs_struct:
4054        if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)        if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4055          return scm_call_generic_2;          return scm_call_generic_2;
4056        else if (!SCM_I_OPERATORP (proc))        else if (!SCM_I_OPERATORP (proc))
4057          return 0;          return NULL;
4058        return scm_call_2;        return scm_call_2;
4059      case scm_tc7_smob:      case scm_tc7_smob:
4060        if (SCM_SMOB_APPLICABLE_P (proc))        if (SCM_SMOB_APPLICABLE_P (proc))
4061          return SCM_SMOB_DESCRIPTOR (proc).apply_2;          return SCM_SMOB_DESCRIPTOR (proc).apply_2;
4062        else        else
4063          return 0;          return NULL;
       /* fall through */  
4064      case scm_tc7_cclo:      case scm_tc7_cclo:
4065      case scm_tc7_pws:      case scm_tc7_pws:
4066        return scm_call_2;        return scm_call_2;
4067      default:      default:
4068        return 0; /* not applicable on two args */        return NULL; /* not applicable on two args */
4069      }      }
4070  }  }
4071    

Legend:
Removed from v.1.296  
changed lines
  Added in v.1.297

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26