/[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.323 by dirk, Sat Oct 11 10:40:17 2003 UTC revision 1.324 by dirk, Sat Oct 11 16:03:28 2003 UTC
# Line 100  char *alloca (); Line 100  char *alloca ();
100   * expression is expected, a 'Bad expression' error is signalled.  */   * expression is expected, a 'Bad expression' error is signalled.  */
101  static const char s_bad_expression[] = "Bad expression";  static const char s_bad_expression[] = "Bad expression";
102    
103    /* If a form is detected that holds less expressions than are required in that
104     * contect, a 'Missing expression' error is signalled.  */
105    static const char s_missing_expression[] = "Missing expression in";
106    
107  /* If a form is detected that holds more expressions than are allowed in that  /* If a form is detected that holds more expressions than are allowed in that
108   * contect, an 'Extra expression' error is signalled.  */   * contect, an 'Extra expression' error is signalled.  */
109  static const char s_extra_expression[] = "Extra expression in";  static const char s_extra_expression[] = "Extra expression in";
# Line 143  static const char s_bad_cond_clause[] = Line 147  static const char s_bad_cond_clause[] =
147   * error is signalled.  */   * error is signalled.  */
148  static const char s_missing_recipient[] = "Missing recipient in";  static const char s_missing_recipient[] = "Missing recipient in";
149    
150    /* If in a position where a variable name is required some other object is
151     * detected, a 'Bad variable' error is signalled.  */
152    static const char s_bad_variable[] = "Bad variable";
153    
154    
155  /* Signal a syntax error.  We distinguish between the form that caused the  /* Signal a syntax error.  We distinguish between the form that caused the
156   * error and the enclosing expression.  The error message will print out as   * error and the enclosing expression.  The error message will print out as
# Line 868  SCM_GLOBAL_SYMBOL(scm_sym_define, s_defi Line 876  SCM_GLOBAL_SYMBOL(scm_sym_define, s_defi
876  /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS  /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
877   * module that does not implement this extension.  */   * module that does not implement this extension.  */
878  SCM  SCM
879  scm_m_define (SCM x, SCM env)  scm_m_define (SCM expr, SCM env)
880  {  {
881    SCM name;    SCM body;
882    x = SCM_CDR (x);    SCM variable;
883    SCM_ASSYNT (scm_ilength (x) >= 2, s_expression, s_define);  
884    name = SCM_CAR (x);    const SCM cdr_expr = SCM_CDR (expr);
885    x = SCM_CDR (x);    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
886    while (SCM_CONSP (name))    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
887      {  
888        /* This while loop realizes function currying by variable nesting. */    body = SCM_CDR (cdr_expr);
889        SCM formals = SCM_CDR (name);    variable = SCM_CAR (cdr_expr);
890        x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x));    while (SCM_CONSP (variable))
891        name = SCM_CAR (name);      {
892          /* This while loop realizes function currying by variable nesting.
893           * Variable is known to be a nested-variable.  In every iteration of the
894           * loop another level of lambda expression is created, starting with the
895           * innermost one.  */
896          const SCM formals = SCM_CDR (variable);
897          const SCM tail = scm_cons (formals, body);
898    
899          /* Add source properties to each new lambda expression:  */
900          const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail);
901    
902          body = scm_list_1 (lambda);
903          variable = SCM_CAR (variable);
904      }      }
905    SCM_ASSYNT (SCM_SYMBOLP (name), s_variable, s_define);    ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
906    SCM_ASSYNT (scm_ilength (x) == 1, s_expression, s_define);    ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
907    
908    if (SCM_TOP_LEVEL (env))    if (SCM_TOP_LEVEL (env))
909      {      {
910        SCM var;        SCM var;
911        x = scm_eval_car (x, env);        const SCM value = scm_eval_car (body, env);
912        if (SCM_REC_PROCNAMES_P)        if (SCM_REC_PROCNAMES_P)
913          {          {
914            SCM tmp = x;            SCM tmp = value;
915            while (SCM_MACROP (tmp))            while (SCM_MACROP (tmp))
916              tmp = SCM_MACRO_CODE (tmp);              tmp = SCM_MACRO_CODE (tmp);
917            if (SCM_CLOSUREP (tmp)            if (SCM_CLOSUREP (tmp)
918                /* Only the first definition determines the name. */                /* Only the first definition determines the name. */
919                && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))                && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))
920              scm_set_procedure_property_x (tmp, scm_sym_name, name);              scm_set_procedure_property_x (tmp, scm_sym_name, variable);
921          }          }
922        var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);        var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
923        SCM_VARIABLE_SET (var, x);        SCM_VARIABLE_SET (var, value);
924        return SCM_UNSPECIFIED;        return SCM_UNSPECIFIED;
925      }      }
926    else    else
927      return scm_cons2 (SCM_IM_DEFINE, name, x);      {
928          SCM_SETCAR (expr, SCM_IM_DEFINE);
929          SCM_SETCAR (cdr_expr, variable);
930          SCM_SETCDR (cdr_expr, body);
931          return expr;
932        }
933  }  }
934    
935    

Legend:
Removed from v.1.323  
changed lines
  Added in v.1.324

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