/[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.331 by dirk, Sat Oct 18 17:24:09 2003 UTC revision 1.332 by dirk, Sat Oct 18 18:26:43 2003 UTC
# Line 1579  scm_m_atbind (SCM expr, SCM env) Line 1579  scm_m_atbind (SCM expr, SCM env)
1579  SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);  SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
1580  SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);  SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
1581    
   
1582  SCM  SCM
1583  scm_m_cont (SCM xorig, SCM env SCM_UNUSED)  scm_m_cont (SCM expr, SCM env SCM_UNUSED)
1584  {  {
1585    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,    const SCM cdr_expr = SCM_CDR (expr);
1586                s_expression, s_atcall_cc);    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1587    return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));    ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1588    
1589      SCM_SETCAR (expr, SCM_IM_CONT);
1590      return expr;
1591  }  }
1592    
1593    
# Line 1593  SCM_SYNTAX (s_at_call_with_values, "@cal Line 1595  SCM_SYNTAX (s_at_call_with_values, "@cal
1595  SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);  SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
1596    
1597  SCM  SCM
1598  scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)  scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
1599  {  {
1600    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,    const SCM cdr_expr = SCM_CDR (expr);
1601                s_expression, s_at_call_with_values);    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1602    return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));    ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
1603    
1604      SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
1605      return expr;
1606  }  }
1607    
1608    
# Line 1622  SCM_SYNTAX (s_gset_x, "set!", scm_i_makb Line 1627  SCM_SYNTAX (s_gset_x, "set!", scm_i_makb
1627  SCM_SYMBOL (scm_sym_setter, "setter");  SCM_SYMBOL (scm_sym_setter, "setter");
1628    
1629  SCM  SCM
1630  scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED)  scm_m_generalized_set_x (SCM expr, SCM env SCM_UNUSED)
1631  {  {
1632    SCM x = SCM_CDR (xorig);    SCM target;
1633    SCM_ASSYNT (2 == scm_ilength (x), s_expression, s_set_x);  
1634    if (SCM_SYMBOLP (SCM_CAR (x)))    const SCM cdr_expr = SCM_CDR (expr);
1635      return scm_cons (SCM_IM_SET_X, x);    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1636    else if (SCM_CONSP (SCM_CAR (x)))    ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
1637      return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)),  
1638                       scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x))));    target = SCM_CAR (cdr_expr);
1639      if (!SCM_CONSP (target))
1640        {
1641          /* R5RS usage */
1642          return scm_m_set_x (expr, env);
1643        }
1644    else    else
1645      scm_misc_error (s_set_x, s_variable, SCM_EOL);      {
1646          /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1647    
1648          const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target));
1649          const SCM setter_proc = scm_cons_source (expr, scm_sym_setter, setter_proc_tail);
1650    
1651          const SCM cddr_expr = SCM_CDR (cdr_expr);
1652          const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target), cddr_expr));
1653    
1654          SCM_SETCAR (expr, setter_proc);
1655          SCM_SETCDR (expr, setter_args);
1656          return expr;
1657        }
1658  }  }
1659    
1660    

Legend:
Removed from v.1.331  
changed lines
  Added in v.1.332

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