/[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.338 by dirk, Sun Nov 2 10:48:10 2003 UTC revision 1.339 by dirk, Sun Nov 2 11:39:35 2003 UTC
# Line 87  char *alloca (); Line 87  char *alloca ();
87    
88    
89    
90    static SCM canonicalize_define (SCM expr);
91    
92    
93    
94  /* {Syntax Errors}  /* {Syntax Errors}
95   *   *
96   * This section defines the message strings for the syntax errors that can be   * This section defines the message strings for the syntax errors that can be
# Line 857  scm_m_cond (SCM expr, SCM env) Line 861  scm_m_cond (SCM expr, SCM env)
861  }  }
862    
863    
864  SCM_SYNTAX(s_define, "define", scm_i_makbimacro, scm_m_define);  SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
865  SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);  SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
866    
867  /* Guile provides an extension to R5RS' define syntax to represent function  /* Guile provides an extension to R5RS' define syntax to represent function
868   * currying in a compact way.  With this extension, it is allowed to write   * currying in a compact way.  With this extension, it is allowed to write
# Line 879  SCM_GLOBAL_SYMBOL(scm_sym_define, s_defi Line 883  SCM_GLOBAL_SYMBOL(scm_sym_define, s_defi
883   */   */
884  /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS  /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
885   * module that does not implement this extension.  */   * module that does not implement this extension.  */
886  SCM  static SCM
887  scm_m_define (SCM expr, SCM env)  canonicalize_define (const SCM expr)
888  {  {
889    SCM body;    SCM body;
890    SCM variable;    SCM variable;
891    
892    const SCM cdr_expr = SCM_CDR (expr);    const SCM cdr_expr = SCM_CDR (expr);
   ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);  
893    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
894    
895    body = SCM_CDR (cdr_expr);    body = SCM_CDR (cdr_expr);
# Line 910  scm_m_define (SCM expr, SCM env) Line 913  scm_m_define (SCM expr, SCM env)
913    ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);    ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
914    ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);    ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
915    
916      SCM_SETCAR (cdr_expr, variable);
917      SCM_SETCDR (cdr_expr, body);
918      return expr;
919    }
920    
921    SCM
922    scm_m_define (SCM expr, SCM env)
923    {
924      SCM canonical_definition;
925      SCM cdr_canonical_definition;
926      SCM body;
927    
928      ASSERT_SYNTAX (scm_ilength (expr) >= 0, s_bad_expression, expr);
929    
930      canonical_definition = canonicalize_define (expr);
931      cdr_canonical_definition = SCM_CDR (canonical_definition);
932      body = SCM_CDR (cdr_canonical_definition);
933    
934    if (SCM_TOP_LEVEL (env))    if (SCM_TOP_LEVEL (env))
935      {      {
936        SCM var;        SCM var;
937          const SCM variable = SCM_CAR (cdr_canonical_definition);
938        const SCM value = scm_eval_car (body, env);        const SCM value = scm_eval_car (body, env);
939        if (SCM_REC_PROCNAMES_P)        if (SCM_REC_PROCNAMES_P)
940          {          {
# Line 930  scm_m_define (SCM expr, SCM env) Line 952  scm_m_define (SCM expr, SCM env)
952      }      }
953    else    else
954      {      {
955        SCM_SETCAR (expr, SCM_IM_DEFINE);        SCM_SETCAR (canonical_definition, SCM_IM_DEFINE);
956        SCM_SETCAR (cdr_expr, variable);        return canonical_definition;
       SCM_SETCDR (cdr_expr, body);  
       return expr;  
957      }      }
958  }  }
959    

Legend:
Removed from v.1.338  
changed lines
  Added in v.1.339

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